SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00039 DOS & ENVIRONMENT ROUTINES 1 05-28-9313:38ALL SWAG SUPPORT TEAM Expand DOS File Handles IMPORT 18 Unit expfht;ππ { Author: Trevor J Carlsen Released into the public domain }π { PO Box 568 }π { Port Hedland }π { Western Australia 6721 }π { Voice +61 91 732 026 }ππ { EXPFHT: This Unit allows an application to expand the number of File }π { handles in use. It is limited to the number permitted by Dos and }π { initialised in the FileS= of the config.sys File. }ππInterfaceππConstπ NumbFiles= 105;π { Set to the number of File handles needed. 99 will be the max With }π { Dos 2.x and 254 With Dos 3.x. (I don't know why not 255!) }πTypeπ fht = Array[1..NumbFiles] of Byte;πVarπ NewFHT : fht;π OldFHT : LongInt;π OldSize : Word;π πFunction MakeNewFHT: Boolean;πProcedure RestoreOldFHT;πππImplementationππConstπ Successful : Boolean = False;ππVarπ OldExitProc : Pointer;ππ{$R-}πFunction MakeNewFHT : Boolean;π { create a new expanded File handle table - True if successful }π Constπ AlreadyUsed : Boolean = False;π beginπ if not AlreadyUsed then beginπ AlreadyUsed := True;π MakeNewFHT := True;π Successful := True;π OldFHT := MemL[PrefixSeg:$34]; { Store the old FHT address }π FillChar(NewFHT,NumbFiles,$ff); { Fill new table With 255 }π Oldsize := MemW[PrefixSeg:$32]; { Store the old FHT size }π MemW[PrefixSeg:$32] := NumbFiles; { Put new size in the psp }π MemL[PrefixSeg:$34] := LongInt(@NewFHT); { new FHT address in psp }π move(Mem[PrefixSeg:$19],NewFHT,$15); { put contents of old to new }π end { if not AllreadyUsed }π else MakeNewFHT := False;π end; { MakeNewFHT }π{$R+}ππ{$F+}πProcedure RestoreOldFHT;π beginπ ExitProc := OldExitProc;π if Successful then beginπ MemW[PrefixSeg:$32] := OldSize;π MemL[PrefixSeg:$34] := OldFHT;π end; π end;π{$F-}ππbeginπ OldExitProc := ExitProc;π ExitProc := @RestoreOldFHT;πend.ππ 2 05-28-9313:38ALL SWAG SUPPORT TEAM Assign New Environment IMPORT 29 {π The following TP code assigns a new Environment to the COMMand.COMπ which is invoked by TP's EXEC Function. In this Case, it is usedπ to produce a Dos PROMPT which is different from the one in the Masterπ Environment. Control is returned when the user Types Exit ...π}ππ{ Reduce Retained Memory }ππ{$M 2048,0,0}ππProgram NewEnv;πUsesπ Dos;πTypeπ String128 = String[128];πConstπ NewPrompt =π 'PROMPT=$e[32mType Exit to Return to The Fitness Profiler$e[0m$_$_$p$g' + #0;πVarπ EnvironNew,π EnvironOld,π offsetN,π offsetO,π SegBytes : Word;π TextBuff : String128;π Found,π Okay : Boolean;π Reg : Registers;ππFunction AllocateSeg( BytesNeeded : Word ) : Word;πbeginπ Reg.AH := $48;π Reg.BX := BytesNeeded div 16;π MsDos( Reg );π if Reg.Flags and FCarry <> 0 thenπ AllocateSeg := 0π elseπ AllocateSeg := Reg.AX;πend {AllocateSeg};ππProcedure DeAllocateSeg( AllocSeg : Word; Var okay : Boolean );πbeginπ Reg.ES := AllocSeg;π Reg.AH := $49;π MsDos( Reg );π if Reg.Flags and FCarry <> 0 thenπ okay := Falseπ elseπ okay := True;πend {DeAllocateSeg};ππFunction EnvReadLn( EnvSeg : Word; Var Envoffset : Word ) : String128;πVarπ tempstr : String128;π loopc : Byte;πbeginπ loopc := 0;π Repeatπ inC( loopc );π tempstr[loopc] := CHR(Mem[EnvSeg:Envoffset]);π inC( Envoffset );π Until tempstr[loopc] = #0;π tempstr[0] := CHR(loopc); {set str length}π EnvReadLn := tempstrπend {ReadEnvLn};ππProcedure EnvWriteLn( EnvSeg : Word; Var Envoffset : Word;π AsciizStr : String );πVarπ loopc : Byte;πbeginπ For loopc := 1 to Length( AsciizStr ) doπ beginπ Mem[EnvSeg:Envoffset] := orD(AsciizStr[loopc]);π inC( Envoffset )π endπend {EnvWriteLn};ππbegin {main}π WriteLn(#10,'NewEnv v0.0 Dec.25.91 Greg Vigneault');π SegBytes := 1024; { size of new environment (up to 32k)}π EnvironNew := AllocateSeg( SegBytes );π if EnvironNew = 0 thenπ begin { asked For too much memory? }π WriteLn('Can''t allocate memory segment Bytes.',#7);π Halt(1)π end;π EnvironOld := MemW[ PrefixSeg:$002c ]; { current environ }π { copy orig env, but change the PROMPT command }π Found := False;π offsetO := 0;π offsetN := 0;π Repeat { copy one env Var at a time, old env to new env}π TextBuff := EnvReadLn( EnvironOld, offsetO );π if offsetO >= SegBytes thenπ begin { not enough space? }π WriteLn('not enough new Environment space',#7);π DeAllocateSeg( EnvironNew, okay );π Halt(2) { abort to Dos }π end;π { check For the PROMPT command String }π if Pos('PROMPT=',TextBuff) = 1 thenπ begin { prompt command? }π TextBuff := NewPrompt; { set new prompt }π Found := True;π end;π { now Write the Variable to new environ }π EnvWriteLn( EnvironNew, offsetN, TextBuff );π { loop Until all Variables checked/copied }π Until Mem[EnvironOld:offsetO] = 0;π { if no prompt command found, create one }π if not Found thenπ EnvWriteLn( EnvironNew, offsetN, NewPrompt );π Mem[EnvironNew:offsetN] := 0; { delimit new environ}π MemW[ PrefixSeg:$2c ] := EnvironNew; { activate new env }π WriteLn( #10, '....Type Exit to return to normal prompt...' );π SwapVectors;π Exec( GetEnv('COMSPEC'),'/S'); {shell to Dos w/ new prompt}π SwapVectors;π MemW[ PrefixSeg:$2c ] := EnvironOld; { restore original env}π DeAllocateSeg( EnvironNew, okay );π if not okay thenπ WriteLn( 'Could not release memory!',#7 );πend {NewEnv}.π(*******************************************************************)π 3 05-28-9313:38ALL SWAG SUPPORT TEAM Warm and Cold Boot IMPORT 6 Procedure Warm_Boot;π Beginπ Inline($BB/$00/$01/$B8/$40/$00/$8E/$D8/π $89/$1E/$72/$00/$EA/$00/$00/$FF/$FF);π End;ππProcedure Cold_Boot;π Beginπ Inline($BB/$38/$12/$B8/$40/$00/$8E/$D8/π $89/$1E/$72/$00/$EA/$00/$00/$FF/$FF);π End;ππI saw that you were posting reboot procedures...I didn't catch what it was forπthough, but maybe these will help.πππ--- XANADU (1:124/7007)π * Origin: * XANADU * Grand Prairie, TX * (1:124/7007)π 4 05-28-9313:38ALL SWAG SUPPORT TEAM Cold Boot in BASM IMPORT 8 # Der User Chris Obee@1:234/26 musste am Donnerstag, dem 22.04.93 um 12:09 Uhrπ# in der Area PASCAL folgendes seiner Tastatur antun................ππ> I would like to write a program in pascal that will accomplish anπ> complete system reboot. The moral equivilent of pressing the big redπ> button. A program that simulates the Cntr-Alt-Del sequence is notπ> sufficient. Anyone who can advise me on if this is possible of not, willπ> receive many thanks.π>π> TTFN: chrisππThat's not as hard as it might seem to be at first glance:ππprogram coldboot;πbeginπ memw[0:$0472] := 0;π asmπ mov ax,$FFFFπ mov ds,axπ jmp far ptr ds:0π end;πend.ππHope you understand the assembler code... :-)πππMichael : [NICO] : [Whoo haz broquen mei brain-waschaer?]π~~~~~~~~~~~~~~~~ππ--- CrossPoint v2.1π * Origin: Send me ALL your money - IMMEDIATELY!! (2:2401/411.2)π 5 05-28-9313:38ALL SWAG SUPPORT TEAM Edit DOS Environment IMPORT 107 {$R-,S-,V-,I-,B-,F-}ππ{Disable the following define if you don't have Turbo Professional}π{$DEFINE UseTpro}ππ{*********************************************************}π{* TPENV.PAS 1.02 *}π{* by TurboPower Software *}π{*********************************************************}ππ{π Version 1.01 11/7/88π Find master environment in Dos 3.3 and 4.0π Version 1.02 11/14/88π Correctly find master environment when runπ Within AUTOEXEC.BATπ}ππUnit TpEnv;π {-Manipulate the environment}ππInterfaceππUses Opus;ππTypeπ EnvArray = Array[0..32767] of Char;π EnvArrayPtr = ^EnvArray;π EnvRec =π Recordπ EnvSeg : Word; {Segment of the environment}π EnvLen : Word; {Usable length of the environment}π EnvPtr : Pointer; {Nil except when allocated on heap}π end;ππConstπ ShellUserProc : Pointer = nil; {Put address of ExecDos user proc here if desiππProcedure MasterEnv(Var Env : EnvRec);π {-Return master environment Record}ππProcedure CurrentEnv(Var Env : EnvRec);π {-Return current environment Record}ππProcedure NewEnv(Var Env : EnvRec; Size : Word);π {-Allocate a new environment on the heap}ππProcedure DisposeEnv(Var Env : EnvRec);π {-Deallocate an environment previously allocated on heap}ππProcedure SetCurrentEnv(Env : EnvRec);π {-Specify a different environment For the current Program}ππProcedure CopyEnv(Src, Dest : EnvRec);π {-Copy contents of Src environment to Dest environment}ππFunction EnvFree(Env : EnvRec) : Word;π {-Return Bytes free in environment}ππFunction GetEnvStr(Env : EnvRec; Search : String) : String;π {-Return a String from the environment}ππFunction SetEnvStr(Env : EnvRec; Search, Value : String) : Boolean;π {-Set environment String, returning True if successful}ππProcedure DumpEnv(Env : EnvRec);π {-Dump the environment to StdOut}ππFunction ProgramStr : String;π {-Return the complete path to the current Program, '' if Dos < 3.0}ππFunction SetProgramStr(Env : EnvRec; Path : String) : Boolean;π {-Add a Program name to the end of an environment if sufficient space}ππ {$IFDEF UseTpro}πFunction ShellWithPrompt(Prompt : String) : Integer;π {-Shell to Dos With a new prompt}π {$endIF}ππProcedure DisposeEnv(Var Env : EnvRec);π {-Deallocate an environment previously allocated on heap}πbeginπ With Env doπ if EnvPtr <> nil then beginπ FreeMem(EnvPtr, EnvLen+31);π ClearEnvRec(Env);π end;πend;ππProcedure SetCurrentEnv(Env : EnvRec);π {-Specify a different environment For the current Program}πbeginπ With Env doπ if EnvSeg <> 0 thenπ MemW[PrefixSeg:$2C] := EnvSeg;πend;ππProcedure CopyEnv(Src, Dest : EnvRec);π {-Copy contents of Src environment to Dest environment}πVarπ Size : Word;π SPtr : EnvArrayPtr;π DPtr : EnvArrayPtr;πbeginπ if (Src.EnvSeg = 0) or (Dest.EnvSeg = 0) thenπ Exit;ππ if Src.EnvLen <= Dest.EnvLen thenπ {Space For the whole thing}π Size := Src.EnvLenπ elseπ {Take what fits}π Size := Dest.EnvLen-1;ππ SPtr := Ptr(Src.EnvSeg, 0);π DPtr := Ptr(Dest.EnvSeg, 0);π Move(SPtr^, DPtr^, Size);π FillChar(DPtr^[Size], Dest.EnvLen-Size, 0);πend;ππProcedure SkipAsciiZ(EPtr : EnvArrayPtr; Var EOfs : Word);π {-Skip to end of current AsciiZ String}πbeginπ While EPtr^[EOfs] <> #0 doπ Inc(EOfs);πend;ππFunction EnvNext(EPtr : EnvArrayPtr) : Word;π {-Return the next available location in environment at EPtr^}πVarπ EOfs : Word;πbeginπ EOfs := 0;π if EPtr <> nil then beginπ While EPtr^[EOfs] <> #0 do beginπ SkipAsciiZ(EPtr, EOfs);π Inc(EOfs);π end;π end;π EnvNext := EOfs;πend;ππFunction EnvFree(Env : EnvRec) : Word;π {-Return Bytes free in environment}πbeginπ With Env doπ if EnvSeg <> 0 thenπ EnvFree := EnvLen-EnvNext(Ptr(EnvSeg, 0))-1π elseπ EnvFree := 0;πend;ππ{$IFNDEF UseTpro}πFunction StUpcase(S : String) : String;π {-Uppercase a String}πVarπ SLen : Byte Absolute S;π I : Integer;πbeginπ For I := 1 to SLen doπ S[I] := UpCase(S[I]);π StUpcase := S;πend;πFunction SearchEnv(EPtr : EnvArrayPtr;π Var Search : String) : Word;π {-Return the position of Search in environment, or $FFFF if not found.π Prior to calling SearchEnv, assure thatπ EPtr is not nil,π Search is not emptyπ }πVarπ SLen : Byte Absolute Search;π EOfs : Word;π MOfs : Word;π SOfs : Word;π Match : Boolean;πbeginπ {Force upper Case search}π Search := Upper(Search);ππ {Assure search String ends in =}π if Search[SLen] <> '=' then beginπ Inc(SLen);π Search[SLen] := '=';π end;ππ EOfs := 0;π While EPtr^[EOfs] <> #0 do beginπ {At the start of a new environment element}π SOfs := 1;π MOfs := EOfs;π Repeatπ Match := (EPtr^[EOfs] = Search[SOfs]);π if Match then beginπ Inc(EOfs);π Inc(SOfs);π end;π Until not Match or (SOfs > SLen);ππ if Match then beginπ {Found a match, return index of start of match}π SearchEnv := MOfs;π Exit;π end;ππ {Skip to end of this environment String}π SkipAsciiZ(EPtr, EOfs);ππ {Skip to start of next environment String}π Inc(EOfs);π end;ππ {No match}π SearchEnv := $FFFF;πend;ππProcedure GetAsciiZ(EPtr : EnvArrayPtr; Var EOfs : Word; Var EStr : String);π {-Collect AsciiZ String starting at EPtr^[EOfs]}πVarπ ELen : Byte Absolute EStr;πbeginπ ELen := 0;π While (EPtr^[EOfs] <> #0) and (ELen < 255) do beginπ Inc(ELen);π EStr[ELen] := EPtr^[EOfs];π Inc(EOfs);π end;πend;ππFunction GetEnvStr(Env : EnvRec; Search : String) : String;π {-Return a String from the environment}πVarπ SLen : Byte Absolute Search;π EPtr : EnvArrayPtr;π EOfs : Word;π EStr : String;π ELen : Byte Absolute EStr;πbeginπ With Env do beginπ ELen := 0;π if (EnvSeg <> 0) and (SLen <> 0) then beginπ {Find the search String}π EPtr := Ptr(EnvSeg, 0);π EOfs := SearchEnv(EPtr, Search);π if EOfs <> $FFFF then beginπ {Skip over the search String}π Inc(EOfs, SLen);π {Build the result String}π GetAsciiZ(EPtr, EOfs, EStr);π end;π end;π GetEnvStr := EStr;π end;πend;ππImplementationππTypeπSO =π Recordπ O : Word;π S : Word;π end;ππProcedure ClearEnvRec(Var Env : EnvRec);π {-Initialize an environment Record}πbeginπ FillChar(Env, SizeOf(Env), 0);πend;ππProcedure MasterEnv(Var Env : EnvRec);π {-Return master environment Record}πVarπ Owner : Word;π Mcb : Word;π Eseg : Word;π Done : Boolean;πbeginπ With Env do beginπ ClearEnvRec(Env);ππ {Interrupt $2E points into COMMAND.COM}π Owner := MemW[0:(2+4*$2E)];ππ {Mcb points to memory control block For COMMAND}π Mcb := Owner-1;π if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) thenπ Exit;ππ {Read segment of environment from PSP of COMMAND}π Eseg := MemW[Owner:$2C];ππ {Earlier versions of Dos don't store environment segment there}π if Eseg = 0 then beginπ {Master environment is next block past COMMAND}π Mcb := Owner+MemW[Mcb:3];π if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) thenπ {Not the right memory control block}π Exit;π Eseg := Mcb+1;π end elseπ Mcb := Eseg-1;ππ {Return segment and length of environment}π EnvSeg := Eseg;π EnvLen := MemW[Mcb:3] shl 4;π end;πend;ππProcedure CurrentEnv(Var Env : EnvRec);π {-Return current environment Record}πVarπ ESeg : Word;π Mcb : Word;πbeginπ With Env do beginπ ClearEnvRec(Env);π ESeg := MemW[PrefixSeg:$2C];π Mcb := ESeg-1;π if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> PrefixSeg) thenπ Exit;π EnvSeg := ESeg;π EnvLen := MemW[Mcb:3] shl 4;π end;πend;ππProcedure NewEnv(Var Env : EnvRec; Size : Word);π {-Allocate a new environment (on the heap)}πVarπ Mcb : Word;πbeginπ With Env doπ if MaxAvail < Size+31 thenπ {Insufficient space}π ClearEnvRec(Env)π else beginπ {31 extra Bytes For paraGraph alignment, fake MCB}π GetMem(EnvPtr, Size+31);π EnvSeg := SO(EnvPtr).S+1;π if SO(EnvPtr).O <> 0 thenπ Inc(EnvSeg);π EnvLen := Size;π {Fill it With nulls}π FillChar(EnvPtr^, Size+31, 0);π {Make a fake MCB below it}π Mcb := EnvSeg-1;π Mem[Mcb:0] := Byte('M');π MemW[Mcb:1] := PrefixSeg;π MemW[Mcb:3] := (Size+15) shr 4;π end;πend;ππFunction SetEnvStr(Env : EnvRec; Search, Value : String) : Boolean;π {-Set environment String, returning True if successful}πVarπ SLen : Byte Absolute Search;π VLen : Byte Absolute Value;π EPtr : EnvArrayPtr;π ENext : Word;π EOfs : Word;π MOfs : Word;π OldLen : Word;π NewLen : Word;π NulLen : Word;πbeginπ With Env do beginπ SetEnvStr := False;π if (EnvSeg = 0) or (SLen = 0) thenπ Exit;π EPtr := Ptr(EnvSeg, 0);ππ {Find the search String}π EOfs := SearchEnv(EPtr, Search);ππ {Get the index of the next available environment location}π ENext := EnvNext(EPtr);ππ {Get total length of new environment String}π NewLen := SLen+VLen;ππ if EOfs <> $FFFF then beginπ {Search String exists}π MOfs := EOfs+SLen;π {Scan to end of String}π SkipAsciiZ(EPtr, MOfs);π OldLen := MOfs-EOfs;π {No extra nulls to add}π NulLen := 0;π end else beginπ OldLen := 0;π {One extra null to add}π NulLen := 1;π end;ππ if VLen <> 0 thenπ {Not a pure deletion}π if ENext+NewLen+NulLen >= EnvLen+OldLen thenπ {New String won't fit}π Exit;ππ if OldLen <> 0 then beginπ {OverWrite previous environment String}π Move(EPtr^[MOfs+1], EPtr^[EOfs], ENext-MOfs-1);π {More space free now}π Dec(ENext, OldLen+1);π end;ππ {Append new String}π if VLen <> 0 then beginπ Move(Search[1], EPtr^[ENext], SLen);π Inc(ENext, SLen);π Move(Value[1], EPtr^[ENext], VLen);π Inc(ENext, VLen);π end;ππ {Clear out the rest of the environment}π FillChar(EPtr^[ENext], EnvLen-ENext, 0);ππ SetEnvStr := True;π end;πend;ππProcedure DumpEnv(Env : EnvRec);π {-Dump the environment to StdOut}πVarπ EOfs : Word;π EPtr : EnvArrayPtr;πbeginπ With Env do beginπ if EnvSeg = 0 thenπ Exit;π EPtr := Ptr(EnvSeg, 0);π EOfs := 0;π WriteLn;π While EPtr^[EOfs] <> #0 do beginπ While EPtr^[EOfs] <> #0 do beginπ Write(EPtr^[EOfs]);π Inc(EOfs);π end;π WriteLn;π Inc(EOfs);π end;π WriteLn('Bytes free: ', EnvFree(Env));π end;πend;π{$IFDEF UseTpro}πFunction ShellWithPrompt(Prompt : String) : Integer;π {-Shell to Dos With a new prompt}πConstπ PromptStr : String[7] = 'PROMPT=';πVarπ PLen : Byte Absolute Prompt;π NSize : Word;π Status : Integer;π CE : EnvRec;π NE : EnvRec;π OldP : String;π OldPLen : Byte Absolute OldP;πbeginπ {Point to current environment}π CurrentEnv(CE);π if CE.EnvSeg = 0 then beginπ {Error getting environment}π ShellWithPrompt := -5;π Exit;π end;ππ {Compute size of new environment}π OldP := GetEnvStr(CE, PromptStr);π NSize := CE.EnvLen;π if OldPLen < PLen thenπ Inc(NSize, PLen-OldPLen);ππ {Allocate and initialize a new environment}π NewEnv(NE, NSize);π if NE.EnvSeg = 0 then beginπ {Insufficient memory For new environment}π ShellWithPrompt := -6;π Exit;π end;π CopyEnv(CE, NE);ππ {Get the Program name from the current environment}π OldP := ProgramStr;ππ {Set the new prompt String}π if not SetEnvStr(NE, PromptStr, Prompt) then beginπ {Program error, should have enough space}π ShellWithPrompt := -7;π Exit;π end;ππ {Transfer Program name to new environment if possible}π if not SetProgramStr(NE, OldP) thenπ ;ππ {Point to new environment}π SetCurrentEnv(NE);ππ {Shell to Dos With new prompt in place}π {Status := Exec('', True, ShellUserProc);}ππ {Restore previous environment}π SetCurrentEnv(CE);ππ {Release the heap space}π if Status >= 0 thenπ DisposeEnv(NE);ππ {Return exec status}π ShellWithPrompt := Status;πend;π{$endIF}ππend.ππ{ EXAMPLE PROGRAM }ππFunction DosVersion : Word;π {-Return the Dos version, major part in AX}πInline(π $B4/$30/ {mov ah,$30}π $CD/$21/ {int $21}π $86/$C4); {xchg ah,al}ππFunction ProgramStr : String;π {-Return the name of the current Program, '' if Dos < 3.0}πVarπ EOfs : Word;π Env : EnvRec;π EPtr : EnvArrayPtr;π PStr : String;πbeginπ ProgramStr := '';π if DosVersion < $0300 thenπ Exit;π CurrentEnv(Env);π if Env.EnvSeg = 0 thenπ Exit;π {Find the end of the current environment}π EPtr := Ptr(Env.EnvSeg, 0);π EOfs := EnvNext(EPtr);π {Skip to start of path name}π Inc(EOfs, 3);π {Collect the path name}π GetAsciiZ(EPtr, EOfs, PStr);π ProgramStr := PStr;πend;ππFunction SetProgramStr(Env : EnvRec; Path : String) : Boolean;π {-Add a Program name to the end of an environment if sufficient space}πVarπ PLen : Byte Absolute Path;π EOfs : Word;π Numb : Word;π EPtr : EnvArrayPtr;πbeginπ SetProgramStr := False;π With Env do beginπ if EnvSeg = 0 thenπ Exit;π {Find the end of the current environment}π EPtr := Ptr(EnvSeg, 0);π EOfs := EnvNext(EPtr);π {Assure space For path}π if EnvLen < PLen+EOfs+4 thenπ Exit;π {Put in the count field}π Inc(EOfs);π Numb := 1;π Move(Numb, EPtr^[EOfs], 2);π {Skip to start of path name}π Inc(EOfs, 2);π {Move the path into place}π Path := Upper(Path);π Move(Path[1], EPtr^[EOfs], PLen);π {Null terminate}π Inc(EOfs, PLen);π EPtr^[EOfs] := #0;π SetProgramStr := True;π end;πend;π 6 05-29-9322:24ALL GAYLE DAVIS Read Environment String IMPORT 14 {$S-,R-,V-,I-,N-,B-,F-}ππ{$IFNDEF Ver40}π {Allow overlays}π {$F+,O-,X+,A-}π{$ENDIF}ππUNIT Self;ππINTERFACEππFUNCTION GetSelf : STRING;πFUNCTION GetSelfPath : STRING;ππIMPLEMENTATIONππFUNCTION GetSelf : STRING;ππ VARπ Temp : STRING;π I, EnvSeg : WORD;π BEGINπ I := 0;π Temp := '';π EnvSeg := memw [prefixseg : $2C]; { have to set this up like any variable! }π WHILE memw [EnvSeg : I] <> 0 DO { read through environment strings }π INC (I);π INC (I, 4); { jump around 2 null bytes & word count }π WHILE mem [EnvSeg : I] <> 0 DO { skim off path & filename }π BEGINπ Temp := Temp + UPCASE (CHR (mem [EnvSeg : I]) );π INC (I);π END;π GetSelf := Temp;πEND; { function GetSelf }πππFUNCTION GetSelfPath : STRING;ππ VARπ Temp : STRING;π I, EnvSeg : WORD;π Place : INTEGER;π BEGINπ I := 0;π Temp := '';π EnvSeg := memw [prefixseg : $2C]; { have to set this up like any variable! }π WHILE memw [EnvSeg : I] <> 0 DO { read through environment strings }π INC (I);π INC (I, 4); { jump around 2 null bytes & word count }π WHILE mem [EnvSeg : I] <> 0 DO { skim off path & filename }π BEGINπ Temp := Temp + UPCASE (CHR (mem [EnvSeg : I]) );π INC (I);π END;π Place := LENGTH (Temp);π WHILE (Place > 0) AND NOT (Temp [Place] IN [':', '\']) DOπ Place := PRED (Place);π IF Place > 0 THEN Temp [0] := CHR (Place);π GetSelfPath := Temp;πEND; { function SelfPath }ππEND.π 7 05-31-9308:06ALL SWAG SUPPORT TEAM Execute & Redirection IMPORT 148 π------------------------------------------------------------------------ππEcho Flag : Permanent: N Export: N Personal Read: Nππ BBS: IN-TECH Conference: PASCAL Imported: 11/14/1991π To: DAVID HICKEY Num: 1442 Date: 10/31/1991πFrom: MARK OUELLET Re: 0 Time: 10:51 pmπSubj: >NUL REDIRECTION Prvt: N Read: Nππ On 27 Oct 91, you, David Hickey, of 1:261/1108.0 wrote...ππ DH> From the DOS prompt, I can redirect things easily. But when I try it in π DH> my program, it doesn't work at all. Here's what I'm doing:π DH> π DH> EXEC ('C:\Pkzip.Exe', '-o c:\ra\ra.zip c:\ra\ralogs\ra.log >nul');π DH> π DH> The problem is that the information from Pkzip is not being redirected π DH> to NULπ DH> like I want it to. It's obviously got to be something I'm not doing π DH> right. Anyone know what it is? I've tried everything I can think of.ππDavid,π This might help you,ππMsg#:20994 *> PASCAL Echo <*π03/17/89 03:15:00πFrom: ROSS WENTWORTHπ To: NORBERT LANGEπSubj: REPLY TO MSG# 20986 (RE: REDIRECTING STDERR)π > I'd appreciate seeing some code. I've tried this before,π > using a couple different methods, and couldn't seem to getπ > DOS to like redirecting StdErr. I tried the $45 (Duplicateπ > File Handle) function as well with no success.ππOk, here's a routine that can be easily modified to do the job. It replaces πEXEC from the DOS unit and checks the "command line" for the redirection πsymbols ('>' and '<'). One minor change and it will redirect STDERR to the πfile (see comment below).π{=============================================================}πUnit Execute;ππInterfaceππProcedure Exec(Path,CmdLine : String);ππImplementationππUsesπ Dos;ππFunction ExtractFileName(Var Line : String;Index : Integer) : String;ππVarπ Temp : String;ππBeginπ Delete(Line,Index,1);π While (Index <= Length(Line)) AND (Line[Index] = ' ')π Do Delete(Line,Index,1);π Temp := '';π While (Index <= Length(Line)) AND (Line[Index] <> ' ') Doπ Beginπ Temp := Temp + Line[Index];π Delete(Line,Index,1);π End;π ExtractFileName := Temp;πEnd;ππProcedure CloseHandle(Handle : Word);ππVarπ Regs : Registers;ππBeginπ With Regs Doπ Beginπ AH := $3E;π BX := Handle;π MsDos(Regs);π End;πEnd;ππProcedure Duplicate(SourceHandle : Word;Var TargetHandle : Word);ππVarπ Regs : Registers;ππBeginπ With Regs Doπ Beginπ AH := $45;π BX := SourceHandle;π MsDos(Regs);π TargetHandle := AX;π End;πEnd;ππProcedure ForceDuplicate(SourceHandle : Word;Var TargetHandle : Word);ππVarπ Regs : Registers;ππBeginπ With Regs Doπ Beginπ AH := $46;π BX := SourceHandle;π CX := TargetHandle;π MsDos(Regs);π TargetHandle := AX;π End;πEnd;ππProcedure Exec(Path,CmdLine : String);ππVarπ StdIn : Word;π Stdout : Word;π Index : Integer;π FName : String[80];π InFile : Text;π OutFile : Text;ππ InHandle : Word;π OutHandle : Word;π { ===============>>>> } { change below for STDERR }πBeginπ StdIn := 0;π StdOut := 1; { change to 2 for StdErr }π Duplicate(StdIn,InHandle); { duplicate standard input }π Duplicate(StdOut,OutHandle); { duplicate standard output }π Index := Pos('>',CmdLine);π If Index > 0 Then { check for output redirection }π Beginπ FName := ExtractFileName(CmdLine,Index); { get output file name }π Assign(OutFile,FName); { open a text file }π Rewrite(OutFile); { .. for output }π ForceDuplicate(TextRec(OutFile).Handle,StdOut);{ make output same }π End;π Index := Pos('<',CmdLine);π If Index > 0 Then { check for input redirection }π Beginπ FName := ExtractFileName(CmdLine,Index); { get input file name }π Assign(InFile,FName); { open a text file }π Reset(InFile); { for input }π ForceDuplicate(TextRec(InFile).Handle,StdIn); { make input same }π End;π DOS.Exec(Path,CmdLine); { run EXEC }π ForceDuplicate(InHandle,StdIn); { put standard input back to keyboard }π ForceDuplicate(OutHandle,StdOut); { put standard output back to screen }π CloseHandle(InHandle); { close the redirected input file }π CloseHandle(OutHandle); { close the redirected output file }πEnd;ππEnd.ππ{===============================================================}ππUse it exactly as you would the normal EXEC procedure:ππ Exec('MASM.EXE','mystuff.asm');ππTo activate redirection simply add the redirection symbols, etc:ππ Exec('MASM.EXE',mystuff.asm >err.lst');πππOne note of caution. This routine temporarily uses extra handles. It'πs eitherπtwo or four more. The various books I have are not clear as two whether πduplicated handles 'count' or not. My guess is yes. If you don't plan on πredirecting STDIN then remove all the code for duplicating it to cut yourπhandle overhead in half.ππ Ross Wentworthππ+++ FD 2.00π Origin: St Dymphna's Retreat via Torrance BBS 213-370-9027 (1:102/345.1)ππ Best regards,π Mark Ouellet.πππ--- ME2π * Origin: The Doctor's Tardis, A point in time!! (Fidonet 1:240/1.4)π==============================================================================π BBS: «« The Information and Technology Exchanπ To: BUTCH ADAMS Date: 12-10─91 (18:00)πFrom: RUSS PARKS Number: 3982 [101] PASCALπSubj: EXEC() Status: Publicπ------------------------------------------------------------------------------π* In a bleating, agonizing plea to All, Butch Adams groaned:ππBA> I'm wondering if I can get some insight as to how toπBA>use the Exec() command in TP6. What I'm trying to do is this:πBA> Exec('Type Filename|sort > newfilename', '');πBA>I've even tried this:πBA> Exec('Type', 'filename|sort > newfilename');ππ Close, but no cigar :-) Try something like this:π Exec('command.com', '/c type filename | sort > newfilename');ππ The first parameter is the path to the program to be run. In thisπcase, 'TYPE' is an internal DOS command so you need to runπCOMMAND.COM. The second parameter is a string with the commandπline arguments you want to pass to the program.π P.S.: The '/c' part of the parameters tells COMMAND.COM to executeπthe command, then exit back to the program that originallyπcalled the COMMAND.COM. It's like loading COMMAND.COM, runningπa program, then typing 'EXIT'.πBesta'Luck,πRussππ---π * Origin: Objectively.Speak('Turbo Pascal 6.0, YEAH!'); (1:170/212)π==============================================================================π BBS: «« The Information and Technology Exchanπ To: BUTCH ADAMS Date: 12-10─91 (21:07)πFrom: MIKE COPELAND Number: 4000 [101] PASCALπSubj: EXEC() Status: Publicπ------------------------------------------------------------------------------π BA> I'm wondering if I can get some insight as to how to use theπ BA>Exec() command in TP6. What I'm trying to do is this:ππ BA> Exec('Type Filename|sort > newfilename', '');ππ BA>I've even tried this:ππ BA> Exec('Type', 'filename|sort > newfilename');ππ BA>But still no result. Are we able to execute internal commands fromπ BA>within a TP program? I've tried loading Command.Com first but all I getπ BA>is the shell to come up and sit there with a C> staring back at me. Iπ BA>would appreciate any help with this.ππ The process to execute any DOS-callable program/command is more thanπyou're doing/showing here. Try the following:ππ{$M 4096,0,0} { allocate space for the child process }ππ SwapVectors;π Exec (GetEnv('COMSPEC'),'/C Type filename|sort > newfile');π SwapVectors;π if DosError > 0 then { check the result of Exec }π You_Have_A_Problem;π if DosExitCode <> 0 thenπ You_Have_A_Different_Problem;π { If you get here, everything's okay... }ππ Read the manual about SwapVectors, DosError, DosExitCode, GetEnv,πExec, the $M parameter, and all the stuff you don't understand here...πππ--- msged 2.07π * Origin: Hello, Keyboard, my old friend... (1:114/18.10)π==============================================================================π BBS: «« The Information and Technology Exchanπ To: ANDREW PARK Date: 12-10─91 (21:15)πFrom: MIKE COPELAND Number: 4001 [101] PASCALπSubj: PASCAL Status: Publicπ------------------------------------------------------------------------------π AP>It's quite simple.π AP>Here's an exampleπ AP>{$M,1025,0,0} <-- I don't know what this means but you need anywaysππ Well, it's very important: it states how much Stack, Heap_Min, andπHeap_Max space you're reserving for the program to use (and howπmuch space you're leaving for the child process to execute in).πThe last (2nd 0) is the most important, since failing to reduceπthis from the default of ALL memory will PREVENT the Exec fromπhaving any memory to do its work within. So, setting it to 0πwill say "reserve ALL of available memory (except for what'sπused by my program itself) for the DOS call I'm going to makeπfrom within my program".π If you don't do this, it defaults to 640K - meaning "reserve NOπmemory for the exec".ππ AP>Program Copying;π AP>Uses dos;π AP>beginπ AP> exec ('Command.com','copy a:*.* b:');π Exec (GetEnv('COMSPEC'),'/C copy a:* b:*');π AP>end.π AP>Something like that. See the manual for Exec section.ππ You should also wrap that Exec call within a pair of SwapVectorsπstatements...before and after. Furthermore, it's a good idea toπcheck DosError and DosExitCode after the action, so see if anyπproblems occurred.π Exec is very useful, but it carries a lot of "baggage" when used...ππ--- msged 2.07π * Origin: Hello, Keyboard, my old friend... (1:114/18.10)π==============================================================================π BBS: «« The Information and Technology Exchanπ To: KEVIN HIGGINS Date: 01-04─92 (09:58)πFrom: MARK OUELLET Number: 4088 [101] PASCALπSubj: RE: HEAP KNOWLEDGE Status: Publicπ------------------------------------------------------------------------------π On 29 Dec 91, you, Kevin Higgins, of 1:128/74.0 wrote...ππ KH> I still don't understand full use of the {$M} compiler directive.π KH> The Pascal tome I have says nothing other than if you don't use New() orπ KH> GetMem() to set the HeapMin and HeapMax to 0. But it never says what toπ KH> set it to if you DO you New or GetMem. Nor could I find any reference onπ KH> ideal settings for a small program which Exec's another fairly smallπ KH> program....ππKevin,π New() and GetMem() are used to allocate spaceπ(memory) off the heap (That which is left of the 640 K ofπdos memory after your program is loaded and DOS and yourπTSRs ect...) for variables that are created AT RUNTIME.πVariables you declare in the usual way ie: Var X : Integer;πallready have space allocated to them.ππ The heap is used to allocate memory to dynamicπvariables ie: variables accessed through the use ofπpointers. These need to have memory allocated to themπ(Unless you are using the pointer to access a region ofπmemory that allready contains information such as theπkeyboard buffer etc... those allready have memory allocatedπto them so you need NO MORE MEMORY TO USE THEM.) Those thatπ*YOU* create such as linked lists need memory. Your programπwhen compiled will only allocate 4 bytes for each pointerπ(Pointers need 2 words, one for the segment, one for theπoffset in that segment) thus the 4 bytes.ππAs a rule of thumb, if you don't create dynamic variablesπthen you can set the $M to: {$M 16384, 0, 0} which is theπminimum.ππ{$MStack space, minimum heap required to run, Max heap needed}ππStack space is the memory needed to hold the stack of yourπprogram, each time you call a function or procedure fromπanother one, the old adress is pushed onto the stack, itπwill pulled off when the called procedure finishes to findπout where to go back and continue executing. Localπvariables, parameters are also saved on the stack so theyπare not lost or modified while the other procedure isπrunning.ππSo if you have recursive procedures (procedures that callπthemselfes) or use lots of parameters you could set a largeπstack. you will find this out through trial and error. If itπdoesn't run properly and halts with a *STACK OVERFLOW* errorπ(TP runtime error 202) then you know you need to increaseπthe stack space allocated to your program.ππThe second parameter is use IF you create dynamic variables,πit tells TP you need at least this much heap memory free toπrun correctly and that it should return to DOS with an errorπif at least that much is not free when you try to load yourπprogram.ππThe last paramater is the Maximum heap memory you expect toπuse, it can be calculated if you know how much you are goingπto use like a big array. If you are using linked lists,πwhich can not allways be evaluated as to how many items theπlist will contain, then you might decide to use it all.πSetting the 3rd parameter to 655360. This won't leave anyπroom to EXEC another program though.ππSo if you intend to run another program from yours, sayπrunning PKUNZIP from a TP program of yours, then you shouldπset Maximum Heap to a value lower than 655360. If you knowπPKUNZIP needs 55k to run without problems then you couldπsimply say:ππ 655360 - (55 * 1024) = 599040ππand set $M toππ{$M 16384, 0, 599040} this will ensure you have at least 55kπfree for PKUNZIP yet giving you the maximum heap space atπthe same time.ππAs allways if you don't use dynamic variables at all don'tπbother with it simply useππ{$M 16384, 0, 0} and you will allways have enough memory toπrun other programs from your TP programs (Unless you don'tπhave enough memory to run them from DOS to begin with ;-) )πππ Best regards,π and a very Happy New Yearπ Mark Ouellet.πππ--- ME2π * Origin: BaseBall for Windows, use the disks as bases ;-) (Fidonet 1:240/1.4)π==============================================================================π BBS: «« The Info-Tech BBS »»π To: SHANE RUSSO Date: 01-24─92 (15:00)πFrom: MIKE COPELAND Number: 5922 [101] $_PASCALπSubj: TP 6.0 -- MEMORY ALLOCATI Status: Publicπ------------------------------------------------------------------------------π SR> Could anyone inform me how to use the $M directive correctly, andπ SR> what it does exactly?ππ SR> Also, what the stack size, heap min and heap max are? (How do youπ SR> calculate the stack size, heap min and heap max)ππ There is no absolute, exact answer to this question, since every TPπprogram has different characteristics and requirements.πHowever, I will try to give you (and others) some basics, fromπwhich you can probably adjust and use as you learn what's rightπfor _you_ (every programmer has different styles, which alsoπaffect the way the $M is used):ππ {$M Stack,Heap_Min,Heap_Max}ππ The Stack is used within your program for calls to subprogramsπ(functions and procedures). Its size is dependent on (1) howπdeep your calls go (or recurse) and (2) how much parameter andπlocal data is referenced during these calls. The worst caseπI've encountered is a recursive sort of strings, where eachπlevel of call requires all the resident data of the routine andπthe parameters passed (string data being so big) are saved onπthe Stack - too many levels of such action will exceed the max.πavailable Stack value, 64K.π So, if you're not making heavily-nested (or recursive) calls in yourπprogram, you won't need much Stack space - 8192 is probably plenty.ππ Heap is data _you_ explicitly ask for (unlike the implicit data usedπby subprogram calls) - by New, GetMem (in TP), or by callingπlibrary routines which do (therefore, you're not always inπcontrol of this if you're using subroutine libraries you didn'tπcreate). The two parameters stated in the $M are for (1) theπminimum value you want to reserve and (2) the maximum you want to allow.π I don't know a good reason to ever use any value > 0 for theπHeap_Min parameter, since the runtime will allocate what'sπneeded (providing the Heap_Max still has something left) -πperhaps performance. So, it's the Heap_Max that's critical forπyour consideration.π I see 2 distinct things here, which are in conflict (and thusπrequire management of this parameter): dynamic memory use inπyour program, and use of the Exec procedure to spawn a childπprocess. If you don't ever do one of these things, then you haveπmaximum use of the other; it's that simple 8<}}.π However (!), doing this is not simple, if you're doing anythingπsophistocated with TP. For instance, if you must use data >64K,πyou've _got_ to use pointers - which implies dynamic memoryπallocation (and consumes the Heap. If, OTOH, you Exec to DOS toπrun other programs or DOS calls from within your program, youπmust leave sufficient memory for DOS to load that otherπprogram, etc. This, of course, depends on what you're Exec-ing.π In either case, your program logic and application must determineπhow much Heap_Max to reserve. The default is 640K (all ofπconventional memory), which prevents _any_ child processπExec-ing. This default will allow maximum possible use ofπdynamic memory (New, GetMem); any need to Exec will require aπreduced value for Heap_Max.π I often do a bit of both in my programs, and I typically use theπfollowing $M parameter:ππ {$M 8192,0,128000}ππand I change either Stack or Heap_Max as I encounter runtime errorsπduring development. Everyone must do the same, for the reasonsπI stated above.π Note that you _won't_ be able to play with this during developmentπin the IDE, since that's a program already consuming a LOT ofπavailable memory.π Hope I made some sense/cleared up some confusion/helped.πππ--- msged 2.07π * Origin: Hello, Keyboard, my old friend... (1:114/18.10)πππ------------------------------------------------------------------------ππEcho Flag : Permanent: N Export: N Personal Read: Nππ BBS: IN-TECH Conference: PASCAL Imported: 11/11/1991π To: ZAK SMITH Num: 1295 Date: 11/03/1991πFrom: TREVOR CARLSEN Re: 0 Time: 1:58 amπSubj: >NUL REDIRECTION Prvt: N Read: Nππ ZS> Change that toπ ZS> EXEC ('C:\COMMAND.COM','c:\pkzip.exe -o ..... >nul');ππI'd reckon that will not work on a majority of systems. Better is ...ππ exec(GetEnv('COMSPEC'),'c:\pkzip...etc');ππThat way it is not command.com specific.ππTeeCeeππ--- TC-ED v2.01 π * Origin: The Pilbara's Pascal Centre (+61 91 732569) (3:690/644)π π 8 06-08-9308:25ALL SWAG SUPPORT TEAM Kill DIR Routine IMPORT 13 (*π===========================================================================π BBS: The Beta ConnectionπDate: 06-05-93 (12:54) Number: 67πFrom: BRENDEN WALKER Refer#: NONEπ To: WAYNE DOYLE Recvd: NOπSubj: DIR. SEARCH Conf: (321) Pascal___Uπ---------------------------------------------------------------------------π WD│ Hi Everyone,π │ I'm interested in finding out how to have the computer search andπ │ find all of the available directories on a disk. I have a program whichπ │ deletes all of *.BAK files on a disk and I'd like to know how it findsπ │ all of the directories.ππ The below example code, will kill a directory and all of it'sπsub-directories. This could be modified to delete all of the .BAK files inπall directories on the hard-drive.ππ Of course, this may not help much, but I rarely use pseudo-code.π*)ππprocedure Kill_Dir(p : pathstr);πvar Od, Rd : pathstr;π Sr : SearchRec;π t : file;ππbeginπ getdir(0,Od);π ChDir(p);π if length(p) > 4 then p := p + '\';π FindFirst('*.*', anyfile, Sr);π while DosError = 0 doπ beginπ temp := p + Sr.Name;π if (Sr.Attr and Directory > 0) thenπ beginπ if (Sr.Name <> '.') and (Sr.Name <> '..') thenπ beginπ Rd := temp;π Kill_Dir(temp);π RmDir(Rd);π end;π endπ elseπ beginπ assign(t,sr.name);π erase(t);π end;π FindNext(Sr);π end;π ChDir(Od);πend;π 9 06-08-9308:26ALL SWAG SUPPORT TEAM National Language SupportIMPORT 32 {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─πMsg : 493 of 505πFrom : Andres Cvitkovich 2:310/36.9 28 Apr 93 22:59πTo : Jon Leosson 2:391/20.0πSubj : Reading the country infoπ────────────────────────────────────────────────────────────────────────────────πHi Jon,ππWednesday, April 14 1993, Jon Leosson wrote to All:ππ JL> Does anybody know how one can read the country info which is set byπ JL> COUNTRY.SYS in DOS 4.0 and 5.0? Any help would be appreciated...ππor DOS 6.0 or DOS 3.x or ... ;-)ππhere we go:ππ---------------------------------------------------------------}πUnit NLS;ππ{ NLS.PAS - National Language Support }π{ ─────────────────────────────────── }π{ (W) Written 1992 by A. Cvitkovich }ππINTERFACEππCONSTπ DATE_USA = 0;π DATE_EUROPE = 1;π DATE_JAPAN = 2;π TIME_12HOUR = 0;π TIME_24HOUR = 1;ππTYPEπ CountryInfo = Recordπ ciDateFormat : Word;π ciCurrency : Array [1..5] Of Char;π ciThousands : Char;π ciASCIIZ_1 : Byte;π ciDecimal : Char;π ciASCIIZ_2 : Byte;π ciDateSep : Char;π ciASCIIZ_3 : Byte;π ciTimeSep : Char;π ciASCIIZ_4 : Byte;π ciBitField : Byte;π ciCurrencyPlaces: Byte;π ciTimeFormat : Byte;π ciCaseMap : Procedure;π ciDataSep : Char;π ciASCIIZ_5 : Byte;π ciReserved : Array [1..10] Of Byteπ End;ππ DateString = String [10];π TimeString = String [10];ππVAR Country : CountryInfo;πππFUNCTION GetCountryInfo (Buf: Pointer): Boolean;πFUNCTION DateStr: DateString;πFUNCTION TimeStr: TimeString;πππIMPLEMENTATIONππUSES Dos;ππFUNCTION GetCountryInfo (Buf: Pointer): Boolean; Assembler;πAsmπ mov ax, 3800hπ push dsπ lds dx, Bufπ int 21hπ mov al, TRUEπ jnc @@1π xor al, alπ@@1:π pop dsπEnd;ππFUNCTION DateStr: DateString;πVAR Year, Month, Day, Weekday : Word;π dd, mm : String[2];π yy : String[4];πBEGINπ GetDate (Year, Month, Day, WeekDay);π Str (Day:2, dd); If dd[1] = ' ' Then dd[1] := '0';π Str (Month:2, mm); If mm[1] = ' ' Then mm[1] := '0';π Str (Year:4, yy);π Case Country.ciDateFormat Ofπ DATE_USA: DateStr := mm + Country.ciDateSep + dd +π Country.ciDateSep + yy;π DATE_EUROPE: DateStr := dd + Country.ciDateSep + mm +π Country.ciDateSep + yy;π DATE_JAPAN: DateStr := yy + Country.ciDateSep + mm +π Country.ciDateSep + dd;π Else DateStr := ''π End;πEND;πππFUNCTION TimeStr: TimeString;πVAR Hour, Min, Sec, Sec100 : Word;π hh, mm, ss : String[2];π ampm : Char;πBEGINπ GetTime (Hour, Min, Sec, Sec100);π Str (Min:2, mm); If mm[1] = ' ' Then mm[1] := '0';π Str (Sec:2, ss); If ss[1] = ' ' Then ss[1] := '0';π Case Country.ciTimeFormat Ofπ TIME_12HOUR: Beginπ If Hour < 12 Then ampm := 'a' Else ampm := 'p';π Hour := Hour MOD 12;π If Hour = 0 Then Hour := 12; Str (Hour:2, hh);π TimeStr := hh + Country.ciTimeSep + mm +π Country.ciTimeSep + ss + ampm + 'm'π End;π TIME_24HOUR: Beginπ Str (Hour:2, hh);π TimeStr := hh + Country.ciTimeSep + mm +π Country.ciTimeSep + ssπ End;π Else TimeStr := ''π End;πEND;πππBEGINπ If Not GetCountryInfo (@Country) Then Beginπ Country.ciDateFormat := DATE_USA;π Country.ciDateSep := '-';π Country.ciTimeFormat := TIME_12HOUR;π Country.ciTimeSep := ':';π End;πEND. 10 06-22-9307:51ALL SWAG SUPPORT TEAM Reboot System Warm/Cold IMPORT 24 ===========================================================================π BBS: Canada Remote SystemsπDate: 06-15-93 (11:09) Number: 8831πFrom: GREG ESTABROOKS Refer#: NONEπ To: KURT TAN Recvd: NO πSubj: REBOOT Conf: (58) PASCALπ---------------------------------------------------------------------------πKT>Can anybody tell me how to reboot with Turbo Pascal?ππ Below are the routines I use to reboot the system.π Hope they help ya.ππ{********************************************************************}πPROGRAM RebootSys; { June 15/93, Greg Estabrooks }πUSES CRT; { Writeln,Readkey,Clrscr }πVARπ CH :CHAR; { Hold Boot Choice }ππPROCEDURE WarmBoot;π { Routine to cause system to do a WARM Boot }πππBEGINπ Inline(π $FB/ { STI }π $B8/00/00/ { MOV AX,0000 }π $8E/$D8/ { MOV DS,AX }π $B8/$34/$12/ { MOV AX,1234 }π $A3/$72/$04/ { MOV [0472],AX }π $EA/$00/$00/$FF/$FF); { JMP FFFF:0000 }πEND;ππPROCEDURE ColdBoot;π { Routine to cause system to do a COLD Boot }πBEGINπ Inline(π $FB/ { STI }π $B8/01/00/ { MOV AX,0001 }π $8E/$D8/ { MOV DS,AX }π $B8/$34/$12/ { MOV AX,1234 }π $A3/$72/$04/ { MOV [0472],AX }π $EA/$00/$00/$FF/$FF); { JMP FFFF:0000 }πEND;ππBEGINπ Clrscr; { Clear the screen }π { Ask for which type of boot to be used }π Writeln('Would You like to do a [W]arm or [C]old Boot? ');π CH := Readkey; { Get Users Choice, }ππ CASE UpCase( CH ) OFπ 'W' : BEGINπ Writeln('Doing a Warm Boot ');π WarmBoot; { Call warm Reboot procedure }π END;π 'C' : BEGINπ Writeln('Doing a Cold Boot ');π ColdBoot; { Call cold reboot procedure }π END;π Else { Else don't reboot at all }π Writeln('Not Rebooting!');π END;πEND.π{***********************************************************************}ππGreg Estabrooks <<Message Entered on 06-15-93 at 09am>>π---π ■ OLX 2.1 TD ■ Beer. It's not just for breakfast anymore!π ■ RoseMail 2.10ß: NANET: VE1EI BBS, Halifax NS, (902)-868-2475π 11 06-22-9309:12ALL SWAG SUPPORT TEAM Another Warm/Cold BOOT IMPORT 19 ===========================================================================π BBS: Canada Remote SystemsπDate: 06-17-93 (20:44) Number: 8849πFrom: GREG VIGNEAULT Refer#: NONEπ To: KURT TAN Recvd: NO πSubj: WARM & COLD TP REBOOT... Conf: (58) PASCALπ---------------------------------------------------------------------------πKT> Can anybody tell me how to reboot with Turbo Pascal?ππ Hi Kurt,ππ You may find that using interrupt $19 doesn't work on many systems.ππ The following cold and warm boot procedures should work under mostπ PC/MS-DOS environments. It doesn't use either ASM or INLINE ...ππ(*******************************************************************)πPROGRAM DemoReboot; { force a Cold or Warm Reboot }ππUSES Crt, { import ClrScr, ReadKey }π Dos; { import Intr(), Registers }ππPROCEDURE Reboot; { <- only call from Cold & WarmBoot }π VAR dummy : Registers; { Intr() needs Register TYPE }π BEGINπ MemW[0:0] := 0; { modify an interrupt vector (eg.0) }π MemW[0:2] := $FFFF; { to point to $FFFF:$0000 }π Intr(0,dummy); { and force a call to it }π END {Reboot};ππPROCEDURE ColdBoot; { like a system power-up or reset }π BEGINπ MemW[0:$472] := $7F7F; { tell the system it's a Cold boot }π Reboot; { ...we don't return from here }π END {ColdBoot};ππPROCEDURE WarmBoot; { same as Ctrl-Alt-Del reboot }π BEGINπ MemW[0:$472] := $1234; { tell the system it's a Warm boot }π Reboot; { ...bye-bye }π END {WarmBoot};ππBEGINπ ClrScr;π Write('Do you want a Warm or Cold reboot (W/C) ? ');π IF UpCase(ReadKey) = 'W' THEN WarmBoot ELSE ColdBoot;ππEND {DemoReboot}.π(*******************************************************************)πππ Greg_ππ Jun.17.1993.Toronto UUCP greg.vigneault@bville.gts.org FIDO 1:250/304π---π ■ RoseMail 2.10ß: NANET 41-62-24 Baudeville -Toronto ON - 416-283-0114π 12 06-22-9309:23ALL SWAG SUPPORT TEAM Dealing with File Share IMPORT 29 ===========================================================================π BBS: Canada Remote SystemsπDate: 06-16-93 (16:14) Number: 26531πFrom: LARS HELLSTEN Refer#: NONEπ To: RITO SALOMONE Recvd: NO πSubj: Re: Novell/File Locking/S Conf: (1221) F-PASCALπ---------------------------------------------------------------------------πRS> Does anyone have any samples of network file sharing/access code for TurboπRS> Pascal/Borland Pascal 6-7.ππ Here's some source that I use. I haven't had a chance to test it outπas much as I'd like to, but so far, it appears to work quite nicely:ππ--- 8< --------------------------------------------------------------------πUnit Share;ππINTERFACEππUses DOS;ππVarπ ShareInstalled : Boolean;ππFunction LockRec(Var Untyped; pos, size : LongInt) : Boolean;πFunction UnLockRec(Var Untyped; pos, size : LongInt) : Boolean;πProcedure FMode(Mode : Byte);πFunction Share : Boolean;ππIMPLEMENTATIONππFunction LockRec(Var Untyped; pos, size : LongInt) : Boolean;ππVarπ Regs : Registers;π f : File absolute Untyped;ππBeginπ pos := pos * FileRec(f).RecSize;π size := size * FileRec(f).RecSize;π Regs.AH := $5C;π Regs.AL := $00;π Regs.BX := FileRec(f).Handle;π Regs.CX := Hi(pos);π Regs.DX := Lo(pos);π Regs.SI := Hi(size);π Regs.DI := Lo(size);π Intr($21,Regs);π LockRec := (Regs.Flags AND FCarry) = 0;πEnd; { LockRec }ππFunction UnLockRec(Var Untyped; pos, size : LongInt) : Boolean;ππVarπ Regs : Registers;π f : File absolute Untyped;ππBeginπ pos := pos * FileRec(f).RecSize;π size := size * FileRec(f).RecSize;π Regs.AH := $5C;π Regs.AL := $01;π Regs.BX := FileRec(f).Handle;π Regs.CX := Hi(pos);π Regs.DX := Lo(pos);π Regs.SI := Hi(size);π Regs.DI := Lo(size);π Intr($21,Regs);π UnlockRec := (Regs.Flags AND FCarry) = 0;πEnd; { UnLockRec }ππProcedure FMode(Mode : Byte);ππBeginπ If ShareInstalled thenπ If (mode in [0..2,23..24,48..50,64..66]) thenπ FileMode := Mode;πEnd;ππfunction Share : boolean;πvar regs : registers;πbeginπ with regs doπ beginπ AH := 16;π AL := 0;π Intr($2f, regs);π Share := AL = 255;π end;πend; { IsShare }ππBeginπ ShareInstalled := Share;πEnd. { MyShare }π--- 8< ---------------------------------------------------------------------ππ By the way, the unit name should be "MyShare", there's duplicateπidentifiers in there by accident. All you do, is call the lock/unlockπroutines, passing the file variable, the record number, and the number ofπrecords (you'll see it determines the size itself, using the FileRec.RecSizeπvariable). The FMode procedure doesn't do much, I just use it instead ofπconstantly putting "If ShareInstalled then FileMode :=..." inside theπprogram(s). You should call this to set the FileMode variable to a sharingπmethod, before you reset the file. Here's a table of values you can pass:ππ Sharing MethodπAccess Method Compatibility Deny Write Deny Read Deny Noneπ-------------------------------------------------------------------πRead Only 0 32 48 64πWrite Only 1 33 49 65πRead/Write 2 34 50 66π-------------------------------------------------------------------ππ--- GEcho 1.00π * Origin: Access-PC BBS ■ Scarborough, ON ■ (416)491-9249 (1:250/320)π 13 07-16-9306:09ALL ROB GREEN DOS ICA Put/Get Routine IMPORT 24 ┤φ ===========================================================================π BBS: Canada Remote SystemsπDate: 06-30-93 (07:05) Number: 28694πFrom: ROB GREEN Refer#: NONEπ To: RAND NOWELL Recvd: NO πSubj: CODE FOR PROGRAM Conf: (1221) F-PASCALπ---------------------------------------------------------------------------π > Another way would be to, upon program startup, is create anπ > enviornment var refering to your program. Say the program isπ > RR.EXE, create a var as Set RR = INSTALLED! then when youπ > shell, search the enviornment for RR, if it equals INSTALLED!π > then present message, if the RR var not exists, then load theπ > program. Of course when the program quits you want to seet RR =π > (nothing).....ππHeres the way i do it...ππunit AmLoaded;ππinterfaceππtypeπ ICAType = recordπ Stext : string[13];π chksum: integer;π end;ππvarπ ica : icaType absolute $0000:$04f0;ππProcedure PutICA(sText:string);ππprocedure GetIca(var stext:string);ππfunction IcaSame(Stext:string):boolean;πππimplementationππProcedure PutICA(sText:string);πvarπ j:byte;πBeginπ fillchar(ica.stext,sizeof(ica.stext),0);π ica.stext:=copy(stext,1,13);π ica.stext[0]:=#13;π Ica.ChkSum:=0;π for j:=0 to 13 doπ Ica.ChkSum:=Ica.ChkSum+ord(ica.stext[j]);πEnd;πππProcedure GetIca(var stext:string);πBeginπ stext:=ica.stext;πEnd;ππfunction IcaSame:boolean;πvarπ j:byte;π k,m:integer;πbeginπ k:=0;π m:=0;π for j:=0 to 13 doπ Beginπ k:=k+ord(ica.stext[j]);π m:=m+ord(stext[j]);π end;π if k=m thenπ Beginπ if ica.chksum=m thenπ IcaSame:=trueπ elseπ IcaSame:=False;π endπ elseπ icasame:=false;πend;ππend.π-----------------------πTest program:ππuses AmLoaded;πBeginπ PutIca('ATEST');π Writeln('ATEST, should come back as same');π {Check to see if we can read it back without changing anything}π If IcaSame('ATEST') thenπ writeln('Same')π elseπ writeln('Not Same');π PutICA('Another Test');π Writeln('Another Test, should come back as not same');π {Change the lower case 'h' into an uppercase 'H'}π Ica.Stext[5]:='H';π If IcaSame('Another Test') thenπ writeln('Same')π elseπ writeln('Not same');π PutIca('hello world');π writeln('Hello world, should come back as not same');π {Change the chksum}π ica.chksum:=111;π If IcaSame('hello world'); thenπ writeln('Same')π elseπ writeln('Not same');πEnd.π-------------------------------------------ππBefore doing EXEC do this:πPutICA('Program name'); {up to 13 chars}πEXEC(getenv('COMSPEC'),'Whatever');πPutIca(' '); {Or null}ππThen when starting your program do this:πIf ICASame('Program name') thenπ writeln('Can''t load Program name on top of itself');πππRobππ--- FMail 0.94π * Origin: The Rush Room - We OWN Orlando - (407) 678 & 0749 (1:363/166)π 14 07-17-9307:28ALL GAYLE DAVIS DOS Critical Errors IMPORT 76 ┤φ {$S-,R-,V-,I-,N-,B-,F-}ππ{$IFNDEF Ver40}π {Allow overlays}π {$F+,O-,X+,A-}π{$ENDIF}ππUNIT CritErr;ππINTERFACEππUSES DOS;ππTYPEπ Str10 = STRING[10];π IOErrorRec = Recordπ RoutineName : PathStr;π ErrorAddr : Str10;π ErrorType : Str10;π TurboResult : Word; { TP Error number }π IOResult : Word; { DOS Extended number }π ErrMsg : PathStr;π End;πππ{}PROCEDURE IOResultTOErrorMessage (IOCode : WORD; VAR MSG : STRING);π{}PROCEDURE GetDOSErrorMessage (VAR Msg : STRING);π{}FUNCTION UserIOError(ErrNum : INTEGER; VAR IOErr : IOErrorRec) : BOOLEAN;π{}PROCEDURE CriticalErrorDOS;π{}PROCEDURE CriticalErrorTP;π{}PROCEDURE CriticalErrorOwn(ErrAddr: POINTER);ππIMPLEMENTATIONππVARπ TurboInt24: POINTER; { Holds address of TP's error handler }ππ function Hex(v: Longint; w: Integer): String;π varπ s : String;π i : Integer;π constπ hexc : array [0 .. 15] of Char= '0123456789abcdef';π beginπ s[0] := Chr(w);π for i := w downto 1 do beginπ s[i] := hexc[v and $F];π v := v shr 4π end;π Hex := s;π end {Hex};πππPROCEDURE CriticalErrorDOS;ππ BEGINπ SetIntVec($24,SaveInt24);π END;ππππPROCEDURE CriticalErrorTP;ππ BEGINπ SetIntVec($24,TurboInt24);π END;ππππPROCEDURE CriticalErrorOwn(ErrAddr: POINTER);ππ BEGINπ SetIntVec($24,ErrAddr);π END;ππππPROCEDURE GetDOSErrorMessage (VAR Msg : STRING);ππTYPE pointerwords =π RECORDπ ofspoint, segpoint : WORD;π END;ππVARπ breakdown : pointerwords ABSOLUTE erroraddr;ππBEGINπIOResultToErrorMessage (ExitCode, MSG);π WITH breakdown DOπ Msg := Msg + ' $' + hex (SegPoint, 4) + ':' + hex (OfsPoint, 4);πEND; {Exitprogram}ππPROCEDURE IOResultToErrorMessage (IOCode : WORD; VAR MSG : STRING);πBEGINπ CASE IOCode OFπ $01 : msg := 'Invalid DOS Function Number';π $02 : msg := 'File not found ';π $03 : msg := 'Path not found ';π $04 : msg := 'Too many open files ';π $05 : msg := 'File access denied ';π $06 : msg := 'Invalid file handle ';π $07 : msg := 'Memory Control Block Destroyed';π $08 : msg := 'Not Enough Memory';π $09 : msg := 'Invalid Memory Block Address';π $0A : msg := 'Environment Scrambled';π $0B : msg := 'Bad Program EXE File';π $0C : msg := 'Invalid file access mode';π $0D : msg := 'Invalid Data';π $0E : msg := 'Unknown Unit';π $0F : msg := 'Invalid drive number ';π $10 : msg := 'Cannot remove current directory';π $11 : msg := 'Cannot rename across drives';π $12 : msg := 'Disk Read/Write Error';π $13 : msg := 'Disk Write-Protected';π $14 : msg := 'Unknown Unit';π $15 : msg := 'Drive Not Ready';π $16 : msg := 'Unknown Command';π $17 : msg := 'Data CRC Error';π $18 : msg := 'Bad Request Structure Length';π $19 : msg := 'Seek Error';π $1A : msg := 'Unknown Media Type';π $1B : msg := 'Sector Not Found';π $1C : msg := 'Printer Out Of Paper';π $1D : msg := 'Disk Write Error';π $1E : msg := 'Disk Read Error';π $1F : msg := 'General Failure';π $20 : msg := 'Sharing Violation';π $21 : msg := 'Lock Violation';π $22 : msg := 'Invalid Disk Change';π $23 : msg := 'File Control Block Gone';π $24 : msg := 'Sharing Buffer Exceeded';π $32 : msg := 'Unsupported Network Request';π $33 : msg := 'Remote Machine Not Listening';π $34 : msg := 'Duplicate Network Name';π $35 : msg := 'Network Name NOT Found';π $36 : msg := 'Network BUSY';π $37 : msg := 'Device No Longer Exists On NETWORK';π $38 : msg := 'NetBIOS Command Limit Exceeded';π $39 : msg := 'Adapter Hardware ERROR';π $3A : msg := 'Incorrect Response From NETWORK';π $3B : msg := 'Unexpected NETWORK Error';π $3C : msg := 'Remote Adapter Incompatible';π $3D : msg := 'Print QUEUE FULL';π $3E : msg := 'No space For Print File';π $3F : msg := 'Print File Cancelled';π $40 : msg := 'Network Name Deleted';π $41 : msg := 'Network Access Denied';π $42 : msg := 'Incorrect Network Device Type';π $43 : msg := 'Network Name Not Found';π $44 : msg := 'Network Name Limit Exceeded';π $45 : msg := 'NetBIOS session limit exceeded';π $46 : msg := 'Filer Sharing temporarily paused';π $47 : msg := 'Network Request Not Accepted';π $48 : msg := 'Print or Disk File Paused';π $50 : msg := 'File Already Exists';π $52 : msg := 'Cannot Make Directory';π $53 : msg := 'Fail On Critical Error';π $54 : msg := 'Too Many Redirections';π $55 : msg := 'Duplicate Redirection';π $56 : msg := 'Invalid Password';π $57 : msg := 'Invalid Parameter';π $58 : msg := 'Network Device Fault';π $59 : msg := 'Function Not Supported By NETWORK';π $5A : msg := 'Required Component NOT Installed';ππ (* Pascal Errors *)π 94 : msg := 'EMS Memory Swap Error';π 98 : msg := 'Disk Full';π 100 : msg := 'Disk read error ';π 101 : msg := 'Disk write error ';π 102 : msg := 'File not assigned ';π 103 : msg := 'File not open ';π 104 : msg := 'File not open for input ';π 105 : msg := 'File not open for output ';π 106 : msg := 'Invalid numeric format ';π 150 : msg := 'Disk is write_protected';π 151 : msg := 'Unknown unit';π 152 : msg := 'Drive not ready';π 153 : msg := 'Unknown command';π 154 : msg := 'CRC error in data';π 155 : msg := 'Bad drive request structure length';π 156 : msg := 'Disk seek error';π 157 : msg := 'Unknown media type';π 158 : msg := 'Sector not found';π 159 : msg := 'Printer out of paper';π 160 : msg := 'Device write fault';π 161 : msg := 'Device read fault';π 162 : msg := 'Hardware Failure';π 163 : msg := 'Sharing Confilct';π 200 : msg := 'Division by zero ';π 201 : msg := 'Range check error ';π 202 : msg := 'Stack overflow error ';π 203 : msg := 'Heap overflow error ';π 204 : msg := 'Invalid pointer operation ';π 205 : msg := 'Floating point overflow ';π 206 : msg := 'Floating point underflow ';π 207 : msg := 'Invalid floating point operation ';π 390 : msg := 'Serial Port TIMEOUT';π 399 : msg := 'Serial Port NOT Responding';ππ 1008 : Msg := 'EMS Memory Swap Error 'π ELSEπ GetDosErrorMessage (Msg);π END;πEND;πππFUNCTION UserIOError(ErrNum : INTEGER; VAR IOErr : IOErrorRec) : BOOLEAN;π{ RETURN ALL INFO ABOUT THE ERROR IF IT OCCURED}πCONSTπ ErrTitles : ARRAY [1..5] OF STRING [10] =π ('System', 'Disk', 'Network', 'Serial', 'Memory');ππVARπ Msg : STRING;π Regs : REGISTERS;ππ BEGINππ UserIOError := FALSE;π FILLCHAR(IOErr,SizeOf(IOErr),#0);π IF ErrNum <=0 THEN EXIT;ππ { GET DOS Extended Error }π WITH Regs DOπ BEGINπ AH := $59;π BX := $00;π MSDOS (Regs);π END;ππ IOResultToErrorMessage (Regs.AX, Msg);ππ IOErr.RoutineName := PARAMSTR (0);π IOErr.ErrorAddr := Hex (SEG (ErrorAddr^), 4) + ':' + Hex (OFS (ErrorAddr^), 4);π IOErr.ErrorType := ErrTitles[Regs.CH];π IOErr.TurboResult := ErrNum;π IOErr.IOResult := Regs.AX;π IOErr.ErrMsg := Msg;ππ UserIOError := (ErrNum > 0);π END;ππBEGINπ GetIntVec($24,TurboInt24);π CriticalErrorDOS;πEND.ππ{ -------------------------- DEMO --------------------- }ππ{ EXAMPLE FOR CRITICAL ERROR HANDLER UNIT }π{ COMPILE AND RUN FROM DOS !!! WILL NOT WORK PROPERLY FROM THE IDE }π{$I-} { A MUST FOR THE CRITICAL HANDLER TO WORK !!!! }ππUSESπ CRT, CRITERR;ππVARπ f: TEXT;π i: INTEGER;π ErrMsg : STRING;π IOErr : IOErrorRec;ππBEGINπ ClrScr;π WriteLn(' EXAMPLE PROGRAM FOR CRITICAL ERROR HANDLER ');π WriteLn;π WriteLn('Turbo Pascal replaces the operating system''s critical-error');π WriteLn('handler with its own. For this demonstration we will generate');π WriteLn('a critical error by attempting to access a diskette that is not');π WriteLn('present. Please ensure that no diskette is in drive A, then');π WriteLn('press RETURN...');π ReadLn;π CriticalErrorTP;π Assign(f,'A:NOFILE.$$$');π WriteLn;π WriteLn('Now attempting to access drive...');π Reset(f);π IF UserIOError(IOResult,IOErr) THENπ BEGINπ WriteLn(IOErr.RoutineName);π WriteLn(IOErr.ErrorAddr);π WriteLn(IOErr.ErrorType);π WriteLn(IOErr.TurboResult);π WriteLn(IOErr.IOResult);π WriteLn(IOErr.ErrMsg);π END;π WriteLn;π Write('Press RETURN to continue...');π ReadLn;π WriteLn;π CriticalErrorDOS;π WriteLn('With the DOS error handler restored, you will be presented');π WriteLn('with the usual "Abort, Retry, Ignore?" prompt when such an');π WriteLn('error occurs. (Later DOS versions allow a "Fail" option.)');π WriteLn('Run this program several times and try different responses.');π Write('Press RETURN to continue...');π ReadLn;π WriteLn('Now attempting to access drive again...');π Reset(f);π IF UserIOError(IOResult,IOErr) THENπ BEGINπ WriteLn(IOErr.RoutineName);π WriteLn(IOErr.ErrorAddr);π WriteLn(IOErr.ErrorType);π WriteLn(IOErr.TurboResult);π WriteLn(IOErr.IOResult);π WriteLn(IOErr.ErrMsg);π END;π Readkey;πEND.ππ 15 08-17-9308:41ALL SWAG SUPPORT TEAM Demostrates EXEC Proc IMPORT 18 ┤φ {$M 8192,0,0}π{* This memory directive is used to makeπ certain there is enough memory leftπ to execute the DOS shell and anyπ other programs needed. *}ππProgram EXEC_Demo;ππ{*ππ EXEC.PASππ This program demonstrates the use ofπ Pascal's EXEC function to executeπ either an individual DOS command orπ to move into a DOS Shell.ππ You may enter any command you couldπ normally enter at a DOS prompt andπ it will execute. You may also hitπ RETURN without entering anything andπ you will enter into a DOS Shell, fromπ which you can exit by typing EXIT.ππ The program stops when you hit aπ 'Q', upper or lower case.π*}πππUses Crt, Dos;ππVarπ Command : String;ππ{**************************************}πProcedure Do_Exec; {*******************}ππ Varπ Ch : Char;ππ Beginπ If Command <> '' Thenπ Command := '/C' + Commandπ Elseπ Writeln('Type EXIT to return from the DOS Shell.');π {* The /C prefix is needed toπ execute any command other thanπ the complete DOS Shell. *}ππ SwapVectors;π Exec(GetEnv('COMSPEC'), Command);π {* GetEnv is used to read COMSPECπ from the DOS environment so theπ program knows the correct pathπ to COMMAND.COM. *}ππ SwapVectors;π Writeln;π Writeln('DOS Error = ',DosError);π If DosError <> 0 Thenπ Writeln('Could not execute COMMAND.COM');π {* We're assuming that the onlyπ reason DosError would be somethingπ other than 0 is if it couldn'tπ find the COMMAND.COM, but thereπ are other errors that can occur,π we just haven't provided for themπ here. *}ππ Writeln;π Writeln;π Writeln('Hit any key to continue...');π Ch := ReadKey;π End;πππFunction Get_Command : String;ππ Varπ Count : Integer;π Cmnd : String;ππ Beginπ Clrscr;π Write('Enter DOS Command (or Q to Quit): ');π Readln(Cmnd);π Get_Command := Cmndπ End;ππBeginπ Command := Get_Command;π While NOT ((Command = 'Q') OR (Command = 'q')) Doπ Beginπ Do_Exec;π Command := Get_Commandπ End;πEnd. 16 08-18-9312:22ALL JOSE ALMEIDA Get the program Name IMPORT 10 ┤φ { Gets the program name.π Part of the Heartware Toolkit v2.00 (HTfile.PAS) for Turbo Pascal.π Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.π I can also be reached at RIME network, site ->TIB or #5314.π Feel completely free to use this source code in any way you want, and, ifπ you do, please don't forget to mention my name, and, give me and Swag theπ proper credits. }ππFUNCTION Get_Prg_Name : String8;ππ{ DESCRIPTION:π Gets the program name.π SAMPLE CALL:π St := Get_Prg_Name;π RETURNS:π The program name, e.g., '12345678'π or '$$$$$$$$' if not available.π NOTES:π This function excludes the .EXE extension of the program. }ππvarπ St : string;π F : byte;π Found : boolean;ππBEGIN { Get_Prg_Name }π St := ParamStr(0);π Found := No;π F := Length(St);π while (F > 0) and (not Found) doπ beginπ if St[F] = '\' thenπ Found := Yesπ elseπ Dec(F);π end;π St := Copy(St,Succ(F),255);π F:= Pos('.',St);π Delete(St,F,255);π if St = '' thenπ St := '$$$$$$$$';π Get_Prg_Name := St;πEND; { Get_Prg_Name }π 17 08-18-9312:30ALL JOSE ALMEIDA Get the Country Code IMPORT 25 ┤φ { Gets the current country code number.π Part of the Heartware Toolkit v2.00 (HTelse.PAS) for Turbo Pascal.π Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.π I can also be reached at RIME network, site ->TIB or #5314.π Feel completely free to use this source code in any way you want, and, ifπ you do, please don't forget to mention my name, and, give me and Swag theπ proper credits. }ππPROCEDURE Get_Country_Code(var CC : word;π var Error_Code : byte);π{ DESCRIPTION:π Gets the current country code number.π SAMPLE CALL:π Get_Country_Code(CC,Error_Code);π RETURNS:π CC : country code numberπ or $FFFF if Error_Code <> 0π Error_Code : see The Programmers PC Source Book 3.191π NOTES:π None. }ππvarπ TmpA : array[1..34] of byte;π HTregs : registers;ππBEGIN { Get_Country_Code }π FillChar(TmpA,SizeOf(TmpA),0);π HTregs.AX := $3800;π HTregs.DX := Ofs(TmpA);π HTregs.DS := Seg(TmpA);π MsDos(HTregs);π if HTregs.Flags and FCarry <> 0 thenπ beginπ CC := $FFFF; { on error set to $FFFF }π Error_Code := HTregs.AL;π endπ elseπ beginπ CC := HTregs.BX;π Error_Code := 0;π end;πEND; { Get_Country_Code }ππππFUNCTION Get_Country_Code_Text(CC : word) : String25;ππ{ DESCRIPTION:π Gets country code in string format.π SAMPLE CALL:π St := Get_Country_Code_Text(CC);π RETURNS:π Country code name.π NOTES:π None. }ππBEGIN { Get_Country_Code_Text }π case CC ofπ 001 : Get_Country_Code_Text := 'United States';π 002 : Get_Country_Code_Text := 'Canada (French)';π 003 : Get_Country_Code_Text := 'Latin America';π 031 : Get_Country_Code_Text := 'Netherlands';π 032 : Get_Country_Code_Text := 'Belgium';π 033 : Get_Country_Code_Text := 'France';π 034 : Get_Country_Code_Text := 'Spain';π 036 : Get_Country_Code_Text := 'Hungary';π 038 : Get_Country_Code_Text := 'Yugoslavia';π 039 : Get_Country_Code_Text := 'Italy';π 041 : Get_Country_Code_Text := 'Switzerland';π 042 : Get_Country_Code_Text := 'Czechoslovakia';π 044 : Get_Country_Code_Text := 'United Kingdom';π 045 : Get_Country_Code_Text := 'Denmark';π 046 : Get_Country_Code_Text := 'Sweden';π 047 : Get_Country_Code_Text := 'Norway';π 048 : Get_Country_Code_Text := 'Poland';π 049 : Get_Country_Code_Text := 'Germany';π 055 : Get_Country_Code_Text := 'Brazil';π 061 : Get_Country_Code_Text := 'International English';π 081 : Get_Country_Code_Text := 'Japan';π 082 : Get_Country_Code_Text := 'Korea';π 086 : Get_Country_Code_Text := 'Peoples Republic of China';π 088 : Get_Country_Code_Text := 'Taiwan';π 351 : Get_Country_Code_Text := 'Portugal';π 358 : Get_Country_Code_Text := 'Finland';π 785 : Get_Country_Code_Text := 'Middle East (Arabic)';π 972 : Get_Country_Code_Text := 'Israel (Hebrew)';π elseπ Get_Country_Code_Text := 'Unknown';π end;πEND; { Get_Country_Code_Text }π 18 08-27-9320:13ALL SEAN PALMER Batch Error Level IMPORT 7 ┤φ {πSEAN PALMERππ> How would I use this Variable after I Exit the pascal Program??ππYou wouldn't. It won't work. What you COULD do though is to have it return anπerrorlevel to Dos if you cancel...π}ππProgram ruSure;πUsesπ Crt;ππProcedure yes;πbeginπ TextAttr := 12;π Writeln('Okay.'); {no error here}πend;ππProcedure no;πbeginπ TextAttr := 26;π Writeln('Aborted.');π halt(1); {report an error to Dos}πend;ππbeginπ TextAttr := 13;π Write('Do you wish to continue? [Y/N]');π Case upcase(ReadKey) ofπ 'Y' : yes;π 'N' : no;π end;πend.π{ππ Now the batch file :ππrusureπREM check For an error from the Programπif errorlevel 1 Goto NOPEπgoto EXITπ:NOPEπcd ..πetc.π 19 08-27-9320:14ALL LARS FOSDAL Self-modifying Batch FileIMPORT 34 ┤φ LARS FOSDALππ> Hi all. I've got a little Program that brings up a Window and severalπ> buttons in TP 7. The buttons have the names of Various batch Files on themπ> which are executed when they are pressed. The batch Files start up Variousπ> other Programs. This launchpad requires about 100K of RAM as currentlyπ> written, and I'm wondering about ways to reduce this amount significantly.π> According to the BP 7 manual resource Files can be used to reduce RAM by 8-π> 10%. Right now the Various buttons' Labels and commands are stored inπ> simple Arrays, which are not the most efficient memory-wise, but I don'tπ> think that making them Records will significantly reduce RAM need. I'd likeπ> to reduce RAM usage an order of magnitude, to about 10K. Any chance ofπ> doing this?ππThere is a dirty way of doing this, and it works With every Dos /πcommand-interpreter that I've tried it under, including Dos 6.0πin a Window under Windows, and 4Dos.ππThe Really nice thing about this way to do it, is that you can evenπload TSR's etc. since the menu Program is not in memory at all and there isπno secondary command interpreter when the user executes his choice.ππThe trick is that you run your Program from a "self-modifying" batchFile.ππ--- MENU.BAT ---π:StartAgainπSET MENU=C:\Dos\MENU.BAT ; Check this environment Var from your menu-progπGOMENU.EXE ; and abort if it is not setπSET MENU=π----------------ππLets say you want to run another batchFile from a menu choice f.x MY.BAT.πLet your Program modify the MENU.BAT to:π---π:StartAgainπSET MENU=C:\Dos\MENU.BATπGOMENU.EXEπSET MENU=πCALL MY.BATπGOTO StartAgainπ---ππWhen you want to terminate your menu-loop, simply modify the MENU.BATπback to it's original state.ππThe menu Program can be shared from a network server. There is noπlimitations at all. You can do Dos commands from the menu Withoutπhaving to load a second shell.ππFollowing my .sig there is a short example Program. It can't be runπdirectly since it Uses some libraries of mine, but you'll get an ideaπof how to do it.πππProgram HitAndRun; {Menusystem}πUsesπ Dos, Crt, LFsystem, LFCrt, LFinput;π{π Written by Lars Fosdalπ May 5th, 1991ππ Released to the public domain, May 15th, 1993π}πConstπ HitAndRunMsg = 'Written by Lars Fosdal ';π Prog = 'HIT&RUN';ππVarπ path : String;ππ{----------------------------------------------------------------------------}ππProcedure Message(MessageIndex : Integer);πbeginπ Writeln(Output);π Writeln(Output, Prog, ' - ', HitAndRunMsg);π Write(Output, 'Error: ');π Case MessageIndex OFπ -1 :π beginπ Write(Output, Prog, ' must be started from ');π Writeln(Output,Path + 'MENU.BAT');π end;π end;π Write(Output,^G);πend;ππProcedure BuildBatchFile(Execute : String);πVarπ BatchFile : Text;πbeginπ Assign(BatchFile, Path + 'MENU.BAT');π ReWrite(BatchFile);π Writeln(BatchFile, '@ECHO OFF');π Writeln(BatchFile, 'REM ' + Prog + ' Menu Minder');π Writeln(BatchFile, 'REM ' + HitAndRunMsg);π Writeln(BatchFile, ':HitAgain');π Writeln(BatchFile, 'SET H&R=BATCH');π Writeln(BatchFile, path + 'HIT&RUN');π if Execute<>'' thenπ beginπ Writeln(BatchFile, Execute);π Writeln(BatchFile, 'GOTO HitAgain');π endπ elseπ Writeln(BatchFile, 'SET H&R=');π Close(BatchFile);πend;ππFunction InitOK : Boolean;πVarπ OK : Boolean;πbeginπ path := BeforeLast('\', ParamStr(0)) + '\';π OK := GetEnv('H&R') = 'BATCH';π InitOK := OK;πend;ππProcedure HitAndRunMenu;πVarπ Mnu : aMenu;π win : aWindow;πbeginπ wDef(Win, 70, 1, 80, 25, 1, Col(Blue, LightGray), Col(Blue, White));π ItemSeparator:= '`';π mBarDefault := Red * 16 + Yellow;π mNew(Mnu, 'Pick an item to run',π 'Quit Menu`COMMAND`DIR /P`D:\BIN\NI'π + '`D:\BIN\MAPMEM`D:\BIN\X3\XTG'π + '`D:\BIN\LIST C:\Dos\MENY.BAT');π Menu(Win, Mnu);π Case Mnu.Entry OFπ 1 : BuildBatchFile('');π elseπ BuildBatchFile(Mnu.Items[Mnu.Entry]^);π end;πend;{HitAndRunMenu}ππbeginπ if InitOK thenπ HitAndRunMenuπ elseπ beginπ Message(-1);π BuildBatchFile('');π end;π Writeln(OutPut);πend.π 20 08-27-9320:49ALL GUY MCLOUGHLIN Dos IPCA IMPORT 10 ┤φ {πGUY MCLOUGHLINππ Program to load data into 16 Byte area of RAM known asπ the Dos "Inter-Process Communication Area".π}ππProgram Load_Dos_IPCA;ππTypeπ arby16 = Array[1..16] of Byte;ππ{ "Absolute" Array Variable used to access the Dos IPCA. }πVarπ IPCA : arby16 Absolute $0000:$04F0;π Index : Byte;ππbeginπ{ Write data to the Dos IPCA. }π For Index := 1 to 16 doπ IPCA[Index] := (100 + Index)πend.ππ{ Program to read data from 16 Byte area of RAM known }π{ as the Dos "Inter-Process Communication Area". }πProgram Read_Dos_IPCA;ππTypeπ arby16 = Array[1..16] of Byte;ππ{ "Absolute" Array Variable used to access the Dos IPCA. }πVarπ IPCA : arby16 Absolute $0000:$04F0;π Index : Byte;ππbeginπ Writeln;π { Display the current data found in the Dos IPCA. }π For Index := 1 to 16 doπ Write(IPCA[Index] : 4);π Writelnπend.ππ{π NOTE:π if you plan on using this in any of your serious applications, I wouldπ recommend using the last 2 Bytes of the IPCA as a CRC-16 error-check. Asπ you have no guarantee that another Program won't use the IPCA too.π} 21 08-27-9320:54ALL SWAG SUPPORT TEAM Dos Environment Unit IMPORT 43 ┤φ {πSubject: Enviro.pas Unit to change Dos Vars permanentlyπππHad this floating round, hope it helps someone.πIt works under Dos 5, NDos 6.01, and should work For any other Dos as well,πno guarantees tho' .ππ}πUnit Enviro;ππInterfaceππVar EnvSeg,π EnvOfs,π EnvSize : Word;ππFunction FindEnv:Boolean;πFunction IsEnvVar(Variable : String;Var Value : String):Boolean;πProcedure ChangeEnvVar(Variable,NewVal : String);ππImplementationππUses Dos;ππType MemoryControlBlock = {MCB -- only needed fields are shown}π Recordπ Blocktag : Byte;π BlockOwner : Word;π BlockSize : Word;π misc : Array[1..3] of Byte;π ProgramName: Array[1..8] of Char;π end;ππ ProgramSegmentPrefix = {PSP -- only needed fields are shown}π Record { offset }π PSPtag : Word; { $20CD or $27CD if PSP} { 00 $00 }π misc : Array[1..21] of Word; { 02 $02 }π Environment: Word { 44 $2C }π end;ππVarπ MCB : ^MemoryControlBlock;π r : Registers;π Found : Boolean;π SegMent : Word;π EnvPtr : Word;π Startofs : Word;ππFunction FindEnvMCB:Boolean;πVarπ b : Char;π BlockType: String[12];π Bytes : LongInt;π i : Word;π last : Char;π MCBenv : ^MemoryControlBlock;π MCBowner : ^MemoryControlBlock;π psp : ^ProgramSegmentPrefix;ππbeginπFindEnvMCB := False;ππBytes := LongInt(MCB^.BlockSize) SHL 4; {size of MCB in Bytes}πif mcb^.blockowner = 0 then { free space }πelse beginπ psp := Ptr(MCB^.BlockOwner,0); {possible PSP}π if (psp^.PSPtag = $20CD) or (psp^.PSPtag = $27CD) then beginπ MCBenv := Ptr(psp^.Environment-1,0);π if MCB^.Blockowner <> (segment + 1) thenπ if psp^.Environment = (segment + 1) thenπ if MCB^.BlockOwner = MCBenv^.BlockOwner then beginπ EnvSize := MCBenv^.BlockSize SHL 4; {multiply by 16}π EnvSeg := PSP^.Environment;π EnvOfs := 0;π FindEnvMCB := True;π endπ endπ end;πend;ππFunction FindEnv:Boolean;πbeginπr.AH := $52; {undocumented Dos Function that returns a Pointer}πIntr ($21,r); {to the Dos 'list of lists' }πsegment := MemW[r.ES:r.BX-2]; {segment address of first MCB found at}π {offset -2 from List of List Pointer }πRepeatπMCB := Ptr(segment,0); {MCB^ points to first MCB}π Found := FindEnvMcb; {Look at each MCB}π segment := segment + MCB^.BlockSize + 1πUntil (Found) or (MCB^.Blocktag = $5A);πFindEnv := Found;πend;ππFunction IsEnvVar(Variable : String;Var Value : String):Boolean;πVar Temp : String;π ch : Char;π i : Word;π FoundIt : Boolean;πbeginπVariable := Variable + '=';πFoundIt := False;πi := EnvOfs;πRepeatπ Temp := '';π StartOfs := I;π Repeatπ ch := Char(Mem[EnvSeg:i]);π if Ch <> #0 then Temp := Temp + Ch;π inc(i);π Until (Ch = #0) or (I > EnvSize);π if Ch = #0 then beginπ FoundIt := (Pos(Variable,Temp) = 1);π if FoundIt then Value := Copy(Temp,Length(Variable)+1,255);π end;πUntil (FoundIt) or (I > EnvSize);πIsEnvVar := FoundIt;πend;ππProcedure ChangeEnvVar(Variable,NewVal : String);πVar OldVal : String;π p1,p2 : Pointer;π i,j : Word;π ch,π LastCh : Char;πbeginπif IsEnvVar(Variable,OldVal) then beginπ p1 := Ptr(EnvSeg,StartOfs + Length(Variable)+1);π if Length(OldVal) = Length(NewVal) thenπ Move(NewVal[1],p1^,Length(NewVal))π else if Length(OldVal) > Length(NewVal) then beginπ Move(NewVal[1],p1^,Length(NewVal));π p1 := ptr(EnvSeg,StartOfs + Length(Variable)+Length(OldVal)+1);π p2 := ptr(EnvSeg,StartOfs + Length(Variable)+Length(NewVal)+1);π Move(p1^,p2^,EnvSize - ofs(p1^));π endπ else begin { newVar is longer than oldVar }π p2 := ptr(EnvSeg,StartOfs + Length(Variable)+Length(NewVal)-length(OldVal)+1);π Move(p1^,p2^,EnvSize - ofs(p2^));π Move(NewVal[1],p1^,Length(NewVal));π end;π endπelse { creating a new Var }π beginπ i := EnvOfs;π ch := Char(Mem[EnvSeg:i]);π Repeatπ LastCh := Ch;π inc(i);π ch := Char(Mem[EnvSeg:i]);π Until (i > EnvSize) or ((LastCh = #0) and (Ch = #0));π if i < EnvSize then beginπ j := 1;π Variable := Variable + '=' + NewVal + #0 + #0;π While (J < Length(Variable)) and (I <= EnvSize) do beginπ Mem[EnvSeg:i] := ord(Variable[j]);π inc(i); Inc(j);π end;π end;π end;πend;ππbeginπend.ππ{ TEST Program }πUses Enviro;ππVar EnvVar : String;ππbeginπif FindEnv then beginπ Writeln('Found the Enviroment !!');π Writeln('Env is at address ',EnvSeg,':',EnvOfs);π Writeln('And is ',EnvSize,' Bytes long');ππ if IsEnvVar('COMSPEC',EnvVar) then Writeln('COMSPEC = ',EnvVar)π else Writeln('COMSPEC is not set');ππ if IsEnvVar('NewVar',EnvVar) then Writeln('NewVar = ',EnvVar)π else Writeln('NewVar is not set');ππ ChangeEnvVar('NewVar','This is a new Var');ππ if IsEnvVar('NewVar',EnvVar) then Writeln('NewVar = ',EnvVar)π else Writeln('NewVar is not set');ππ ChangeEnvVar('NewVar','NewVar is now this');ππ if IsEnvVar('NewVar',EnvVar) then Writeln('NewVar = ',EnvVar)π else Writeln('NewVar is not set');ππ end;πend.π 22 08-27-9321:02ALL MARK LEWIS Extend DOS to 255 Files IMPORT 23 ┤φ {πMARK LEWISππ> The problem is that Without allocating a new FCB For Dos, youπ> can't have more than 15 or so Files open at a time in TP, noπ> matter WHAT the CONFIG.SYS FileS= statement says. (By default,ππi cannot remember exactly what INT $21 Function $6700 is but here's a PD Unitπi got from borland's bbs the other day... i've trimmed the Text down forπposting... if anyone Really needs everything that comes With it, they shouldπlook For EXTend6.*π}ππUnit Extend;π{ This extends the number of File handles from 20 to 255 }π{ Dos requires 5 For itself. Applications can use up to 250 }ππInterfaceππImplementationπUsesπ Dos;ππConstπ Handles = 255;π { You can reduce the value passed to Handles if fewer Files are required. }ππVarπ Reg : Registers;π beginπ { Check the Dos Version - This technique only works For Dos 3.0 or later }π Reg.ah := $30;π MsDos(Reg);π if Reg.al<3 thenπ beginπ Writeln('Extend Unit Require Dos 3.0 or greater');π halt(1);π end;ππ {Reset the FreePtr - This reduces the heap space used by Turbo Pascal}π if HeapOrg <> HeapPtr thenπ {Checks to see if the Heap is empty}π beginπ Write('Heap must be empty before Extend Unit initializes');π Writeln;π halt(1);π end;π Heapend := ptr(Seg(Heapend^) - (Handles div 8 + 1), Ofs(Heapend^));ππ {Determine how much memory is allocated to Program}π {Reg.Bx will return how many paraGraphs used by Program}π Reg.ah := $4A;π Reg.es := PrefixSeg;π Reg.bx := $FFFF;π msDos(Reg);ππ {Set the Program size to the allow For new handles}π Reg.ah := $4A;π Reg.es := PrefixSeg;π Reg.bx := reg.bx - (Handles div 8 + 1);π msDos(Reg);ππ {Error when a Block Size is not appropriate}π if (Reg.flags and 1) = 1 thenπ beginπ Writeln('Runtime Error ', Reg.ax, ' in Extend.');π halt(1);π end;ππ {Allocate Space For Additional Handles}π reg.ah := $67;π reg.bx := Handles;π MsDos(reg);πend.ππ{πWrite the following Program to a separate File. This Program tests the EXTendπUnit. This test should be done on systems equipped With a hard disk.π}ππProgram TestEx;ππUsesπ EXTend;ππTypeπ FileArray = Array [1..250] of Text;ππVarπ f : ^FileArray;π i : Integer;π s : String;ππbeginπ {Allocate Space For fILE Variable Table}π new(f);π {oPEN 250 Files simultaneously}π For i:=1 to 250 doπ beginπ str(i,s);π Assign(f^[i],'Dum'+s+'.txt');π reWrite(f^[i]);π Writeln('Open #',s);π end;π {Write some Text to the Files}π For i:=1 to 250 doπ Write(f^[i],'This is a test File');π {Close the Files}π For i:=1 to 250 doπ beginπ close(f^[i]);π Writeln('Closing #',i);π end;π {Erase the Files}π For i:=1 to 250 doπ beginπ erase(f^[i]);π Writeln('Erasing #',i);π end;πend.ππ 23 08-27-9321:43ALL BJOERN JOENSSON Detect OS2 IMPORT 3 ┤φ {πBJOERN JOENSSONππBTW, OS/2 is easy to detect because the major Dosπversion # is greater than 10:π}ππFunction DetectOs2 : Boolean;πbeginπ { if you use Tpro, then Write Hi(TpDos.DosVersion) }π DetectOs2 := (Lo(Dos.DosVersion) > 10);πend;π 24 08-27-9321:50ALL EMMANUEL CECCHET Cold/Warm Boot IMPORT 3 ┤φ {πFreeWare by Emmanuel CECCHETπ(C) 1992 3D CONCEPT PRODUCTIONπ}ππProcedure Cold_Boot; Assembler;πAsmπ mov AX,1700hπ int 14hπend;ππProcedure Warm_Boot; Assembler;πAsmπ mov AX,1701hπ int 14hπend;π 25 08-27-9321:57ALL LARS HELLSTEN Detecting SHARE IMPORT 12 ┤φ {πLARS HELLSTENππ> I would like to open a few Files in READ, DENY Write mode. I can get the rπ> part (just a reset), but not the DENY Write. How can I accomplish this inπ> Turbo Pascal Without locking specific Records or parts of Files, or the whoπ> File... or is that what is required?ππYou can accomplish that by changing the FileMODE Variable. Iπdon't know if that's what you're looking for, or already know this,πbut, here's a table of FileMODE values:π Sharing MethodπAccess Method Compatibility Deny Write Deny Read Deny Noneπ--------------------------------------------------------------πRead Only 0 32 48 64πWrite Only 1 33 49 65πRead/Write 2 34 50 66π--------------------------------------------------------------ππ So, as you can see, all you need to do is set the FileMODE to 32. Justπput the satement "FileMode := 32;" in before you reset the File. This willπonly work With Dos' SHARE installed, or a compatible network BIOS. if youπneed a routine to detect SHARE, here's one:π}ππUsesπ Dos;ππFunction ShareInstalled : Boolean;πVarπ Regs : Registers;πbeginπ Regs.AH := $16;π Regs.AL := $00;π Intr($21, Regs);π ShareInstalled := (Regs.AL = $FF);πend;ππbeginπ Writeln('Share: ', ShareInstalled);πend. 26 08-27-9322:06ALL ALEXANDER KUGEL Trap DOS Error IMPORT 39 ┤φ {πAlexander Kugelππ There was a discussion about how to trap floating point errorsπin TP. Here is the solution that traps any kind of run-timeπerrors. The idea is not mine. I saw it in a russian book about TPπand OOP.ππ The idea is quite simple. Instead of trying to trap all kind ofπerrors, we can let TP to do the job For us. Whenever TP stopsπexecution of the Program ( because of a run time error or justπbecause the Program stops in a natural way ) it executes theπdefault Procedure of Exit : ExitProc. Then TP checks the status ofπtwo Variables from the SYSTEM Unit : ErrorAddr and ExitCode. Ifπthere was a run time error then ErrorAddr is not NIL and ExitCodeπcontaines the run time error code. Otherwise ExitCode containes theπerrorlevel that will be set For Dos and ErrorAddr is NIL.πFortunatly we can easily redefine the ExitProc, and thus toπovertake the control from TP. The problem is that we got to be ableπto get back or to jump to any point of the Program ( even to jumpπinside a Procedure / Function). The author of the book claimed thatπhe took his routines from Turbo Professional.ππ Well, there are two Files you are gonna need. Save the first oneπas JUMP.PAS Compile it as a Unit. The second one is a short Programπthat shows how to use it. It asks For two numbers, divides theπfirst by the second and takes a natural logarithm of the result.πTry to divide by zero, logarithm of a negative number. Try enteringπletters instead of numbers and see how the Program recovers.ππ The trapping works fine under Windows/Dos. To run it WithπWindowS recompile the JUMP Unit For Windows target. Then add WinCrtπto the Uses statement and remove Mark/Release lines ( because thereπis no Mark/Release For Windows ).ππ------------------------------jump.pas-----------------------------π}ππUnit Jump;ππInterfaceππTypeπ JumpRecord = Recordπ SpReg,π BpReg : Word;π JmpPt : Pointer;π end;ππProcedure SetJump(Var JumpDest : JumpRecord);π{Storing SP,BP and the address}πInline(π $5F/ {pop di }π $07/ {pop es }π $26/$89/$25/ {mov es:[di],sp }π $26/$89/$6D/$02/ {mov es:[di+2],bp }π $E8/$00/$00/ {call null }π {null: }π $58/ {pop ax }π $05/$0C/$00/ {add ax,12 }π $26/$89/$45/$04/ {mov es:[di+4],ax }π $26/$8C/$4D/$06); {mov es:[di+6],cs }π {next: }ππProcedure LongJump(Var JumpDest : JumpRecord);π{Restore everything and jump}πInline(π $5F/ {pop di }π $07/ {pop es }π $26/$8B/$25/ {mov sp,es:[di] }π $26/$8B/$6D/$02/ {mov bp,es:[di+2] }π $26/$FF/$6D/$04); {jmp far es:[di+4]}ππImplementationππend.ππ{ ------------------------------try.pas------------------------------ }ππProgram Try;πUsesπ Jump; {Uses Jump,WinCrt;}ππVarπ OldExit : Pointer;π MyAddr : JumpRecord;π MyHeap : Pointer;ππ a1,a2,π a3,a4 : Real;πππ{$F+}πProcedure MyExit;π{You can add your error handler here}πbeginπ if ErrorAddr <> Nil Thenπ beginπ Case ExitCode ofπ 106 : Writeln('Invalid numeric format');π 200 : Writeln('Division by zero');π 205 : Writeln('Floating point overflow');π 206 : Writeln('Floating point underflow');π 207 : Writeln('Invalid floating point operation');π else Writeln('Hmmm... How did you do that ?');π end;π ErrorAddr := Nil;π LongJump(MyAddr);π end;π ExitProc := OldExit;πend;π{$F-}ππbeginπ OldExit := ExitProc;π Mark(MyHeap);π {Just an example of how to restore the heap }π {Actually we don't have to do that in }π {this Program, because we dont use heap }π {at all. But anyway here it goes }ππ {Don't forget to remove when compiling this }π {for Windows }ππ SetJump(MyAddr);ππ {We'll get back here whenever a run time }π {error occurs }π {This line should always be before }π { ExitProc:=MyExit; }π {Don't ask me why... It's much easier For me}π {to follow the rule then to understand it :)}ππ ExitProc := @MyExit;ππ Release(MyHeap);π {restoring the heap after a run time error }π {Remove this if you are compiling it For }π {Windows }ππ {Try entering whatever you want at the }π {prompt. It should trap every runtime error}π {you could possibly get. }ππ Repeatπ Writeln;π Write('Enter a number a1=');π Readln(a1);π Write('Enter a number a2=');π Readln(a2);π a3 := a1 / a2;π Writeln('a1/a2=', a3 : 10 : 5);π a4 := ln(a3);π Writeln('ln(a1/a2)=', a4 : 10 : 5);π Until a3 = 1;πend.π 27 08-27-9322:10ALL SWAG SUPPORT TEAM DOS Volume Labels IMPORT 30 ┤φ {π> I need a way to find the volume Label of a drive. Any suggestions orπ> source code?π}π{$S-,R-,V-,I-,N-,B-,F-}ππUnit Volume;ππInterfaceππUsesπ Dos;ππTypeππ Drive = Byte;π VolumeName = String [11];ππ VolFCB = Recordπ FCB_Flag : Byte;π Reserved : Array [1..5] of Byte;π FileAttr : Byte;π Drive_ID : Byte;π FileName : Array [1..8] of Byte;π File_Ext : Array [1..3] of Byte;π Unused_A : Array [1..5] of Byte;π File_New : Array [1..8] of Byte;π fExt_New : Array [1..3] of Byte;π Unused_B : Array [1..9] of Byteπ end;ππFunction DelVol (D : Byte) : Boolean;πFunction AddVol (D : Byte; V : VolumeName) : Boolean;πFunction ChgVol (D : Byte; V : VolumeName) : Boolean;πFunction GetVol (D : Byte) : VolumeName;ππImplementationππProcedure Pad_Name (Var V : VolumeName);πbeginπ While LENGTH (V) <> 11 DOπ V := V + ' 'πend;ππFunction Fix_Ext_Sym (Var V : VolumeName) : Byte;πVarπ I : Byte;πbeginπ I := POS ('.', V);π if I > 0 thenπ DELETE (V, I, 1);π Fix_Ext_Sym := Iπend;ππFunction Extract_Name (S : SearchRec) : VolumeName;πVarπ H, I : Byte;πbeginπ I := Fix_Ext_Sym (S.Name);π if (I > 0) and (I < 9) thenπ For H := 1 to (9 - I) DOπ INSERT (' ', S.Name, I);π Extract_Name := S.Nameπend;ππProcedure Fix_Name (Var V : VolumeName);πVarπ I : Byte;πbeginπ Pad_Name (V);π For I := 1 to 11π do V [I] := UPCASE (V [I])πend;ππFunction Valid_Drive_Num (D : Byte) : Boolean;πbeginπ Valid_Drive_Num := (D >= 1) and (D <= 26)πend;ππFunction Find_Vol (D : Byte; Var S : SearchRec) : Boolean;πbeginπ FINDFIRST (CHR (D + 64) + ':\*.*', VolumeID, S);π Find_Vol := DosError = 0πend;ππProcedure Fix_FCB_NewFile (V : VolumeName; Var FCB : VolFCB);πVarπ I : Byte;πbeginπ For I := 1 to 8 DOπ FCB.File_New [I] := ORD (V [I]);π For I := 1 to 3 DOπ FCB.fExt_New [I] := ORD (V [I + 8])πend;ππProcedure Fix_FCB_FileName (V : VolumeName; Var FCB : VolFCB);πVarπ I : Byte;πbeginπ For I := 1 to 8 DOπ FCB.FileName [I] := ORD (V [I]);π For I := 1 to 3 DOπ FCB.File_Ext [I] := ORD (V [I + 8])πend;ππFunction Vol_Int21 (Fnxn : Word; D : Drive; Var FCB : VolFCB) : Boolean;πVarπ Regs : Registers;πbeginπ FCB.Drive_ID := D;π FCB.FCB_Flag := $FF;π FCB.FileAttr := $08;π Regs.DS := SEG (FCB);π Regs.DX := OFS (FCB);π Regs.AX := Fnxn;π MSDos (Regs);π Vol_Int21 := Regs.AL = 0πend;ππFunction DelVol (D : Byte) : Boolean;πVarπ sRec : SearchRec;π FCB : VolFCB;π V : VolumeName;πbeginπ DelVol := False;π if Valid_Drive_Num (D) thenπ beginπ if Find_Vol (D, sRec) thenπ beginπ V := Extract_Name (sRec);π Pad_Name (V);π Fix_FCB_FileName (V, FCB);π DelVol := Vol_Int21 ($1300, D, FCB)π endπ endπend;ππFunction AddVol (D : Byte; V : VolumeName) : Boolean;πVarπ sRec : SearchRec;π FCB : VolFCB;πbeginπ AddVol := False;π if Valid_Drive_Num (D) thenπ beginπ if not Find_Vol (D, sRec) thenπ beginπ Fix_Name (V);π Fix_FCB_FileName (V, FCB);π AddVol := Vol_Int21 ($1600, D, FCB)π endπ endπend;ππFunction ChgVol (D : Byte; V : VolumeName) : Boolean;πVarπ sRec : SearchRec;π FCB : VolFCB;π x : Byte;πbeginπ ChgVol := False;π if Valid_Drive_Num (D) thenπ beginπ if Find_Vol (D, sRec) thenπ beginπ x := Fix_Ext_Sym (V);π Fix_Name (V);π Fix_FCB_NewFile (V, FCB);π V := Extract_Name (sRec);π Pad_Name (V);π Fix_FCB_FileName (V, FCB);π ChgVol := Vol_Int21 ($1700, D, FCB)π endπ endπend;ππFunction GetVol (D : Byte) : VolumeName;πVarπ sRec : SearchRec;πbeginπ GetVol := '';π if Valid_Drive_Num (D) thenπ if Find_Vol (D, sRec) thenπ GetVol := Extract_Name (sRec)πend;ππend.π 28 11-02-9318:40ALL BILL BUCHANAN More REBOOT SWAG9311 7 ┤φ {===========================================================================πDate: 10-02-93 (04:20)πFrom: BILL BUCHANANπ To: JON DERAGONπSubj: BOOT IT!ππ> Hi everyone! Just wondering if anyone out there knows how to makeπ> the computer do a RESET using a small Pascal routine? Need it ASAP asπ> part of a pretty large project currently in the final stages ofπ> completion. }ππprogram Reboot;πbeginπ Inline ($EA/$F0/$FF/$00/$F0)πend.ππProcedure ColdBoot; Assembler;π Asmπ Xor AX, AXπ Mov ES, AXπ Mov Word PTR ES:[472h],0000h {This is NOT a WARM boot}π Mov AX, 0F000hπ Push AXπ Mov AX, 0FFF0hπ Push AXπ Retfπ End;π 29 11-02-9317:23ALL CHRIS PRIEDE SAFEBOOT with FLUSH SWAG9311 4 ┤φ {πFrom: CHRIS PRIEDEπSubj: Rebooting...ππissue DOS Flush Buffers call AND reboot }ππprocedure SafeReboot; far; assembler;πasmπ mov ah, 0Dhπ int 21hπ xor cx, cxπ@1:π push cxπ int 28hπ pop cxπ loop @1π mov ds, cxπ mov word ptr [472h], 1234hπ dec cxπ push cxπ push dsπend;π 30 10-28-9311:34ALL GREG VIGNEAULT APPEND, ASSIGN & SHARE SWAG9311 26 ┤φ {===========================================================================πDate: 09-22-93 (08:41)πFrom: GREG VIGNEAULTπSubj: APPEND, ASSIGN, & SHAREπ---------------------------------------------------------------------------πJS> How could I determine if DOS extension utilities (eg. Append,π > Assign, and Share) are installed, using Turbo Pascal? }ππ(* Turbo/Quick/StonyBrook Pascal: Determine if extensions installed *)πPROGRAM DosExt; { DOSEXT.PAS: Greg Vigneault 93.10.02 }ππUSES Dos; { Import Intr(), MsDos(), Registers }ππTYPE Extension = (Append, Assign, Share); { the PC/MS-DOS extensions }ππVAR Reg : Registers; { to access Intel 80x86 CPU registers }π Status : WORD; { to return system extension status }π Installed : Extension; { DOS extension (Append|Assign|Share) }π Okay : BOOLEAN; { success or failure (TRUE|FALSE) }π Func : BYTE; { the multiplex function number }ππ(*------------------------------------------------------------------*)πFUNCTION DosVersion : WORD; { to check DOS version }π BEGINπ Reg.AH := $30; { function:get DOS ver }π MsDos (Reg); { call DOS services }π DosVersion := Reg.AL * 100 + Reg.AH; { ...version times 100 }π END {DosVersion};ππ(*------------------------------------------------------------------*)πFUNCTION Multiplex (Func : WORD; VAR Status : WORD) : BOOLEAN;π BEGINπ Reg.AH := Func; { function number }π Reg.AL := 0; { subfunction:get status }π Intr ($2F,Reg); { do multiplex interrupt }π IF (Reg.Flags AND 1) <> 0 THEN BEGIN { an error condition? }π Status := Reg.AX; { the DOS error code }π Multiplex := FALSE; END { and flag the error }π ELSE BEGINπ Status := WORD(Reg.AL); { the function status }π Multiplex := TRUE; { and flag success }π END;π END {Multiplex};ππ(*------------------------------------------------------------------*)πBEGIN {DosExt}ππ WriteLn;π IF DosVersion < 330 THEN BEGINπ WriteLn ('PC/MS-DOS version is too low, sorry.');π Halt (1);π END;ππ FOR Installed := Append TO Share DO BEGINπ CASE Installed OFπ Append : BEGIN Write ('APPEND '); Func := $B7; END;π Assign : BEGIN Write ('ASSIGN '); Func := $02; END;π Share : BEGIN Write ('SHARE '); Func := $10; END;π END; {CASE}π IF NOT Multiplex (Func,Status) THENπ WriteLn ('status unknown (MS-DOS error #',Status,').')π ELSEπ CASE Status OFπ 0,1 : BEGINπ Write ('not installed: ');π IF Status = 1 THEN Write ('and NOT ');π WriteLn ('okay to install.');π END;π 255 : WriteLn ('is installed.');π END; {CASE & IF}π END; {FOR}ππEND {DosExt}.π(********************************************************************)π 31 09-26-9310:17ALL HELGE HELGESEN SHARE Unit in ASM SWAG9311 38 ┤φ (*πFrom: HELGE HELGESENπSubj: SHARE.EXEπ---------------------------------------------------------------------------π-> Can I lock the files after the RESET and unlock before / afterπ-> the close?ππYes. This is one advantage of network files. All users runningπyour program will open the files simultaneously, and when aπprocess wants to write to a record, it simply locks it. No otherπprocesses can then read or write to the record, though they canπread/write all other records.ππ(I assume you're NOT using text files!)ππ-> I'd like to add a thing that checks if the file is lockedπ-> before the reset.ππIf a record is locked, then the process still can open the file.ππ-> Does the "lock" occur on the open or the read of the file?ππWhat do you mean? You can open a file in numerous ways. If youπopen it for shDenyN, then locking is done on record(byte) basis.πIf you open it for exclusive(FileMode=2) access or shDenyRW (noπother can access the file) then locking is done on file basis.ππHere's a short unit with file locking support. It's written forπTurbo Pascal (or Borland Pascal) 7.0, but it should work withπTP60 without many modifications.πSHARE.PAS --->π*)ππUnit Share;π{π Utility to allow file sharing on a networkπ (c) 1993 Helge Olav Helgesenπ}ππinterfaceππusesπ dos;ππfunction shShareInstalled: boolean; { check if SHARE is installed }πfunction LockByte(var thefile; FirstByte, NoBytes: longint): byte;πfunction UnLockByte(var thefile; FirstByte, NoBytes: longint): byte;πfunction Lock(var thefile; FirstRec, NoRecs: word): byte;πfunction UnLock(var thefile; FirstRec, NoRecs: word): byte;ππconstπ{π Here's a list of file file modes you can open a file with. To allowπ multiple access to one file, it should either be marked R/O, or openedπ with shDenyN-mode. To open a file with a spesified mode, do:ππ FileMode:=shDenyN+shAccessRW; (Add the flags)π}π shDenyR = $30; { Deny Read to other Processes }π shDenyW = $20; { Deny Write to other Processes }π shDenyRW = $10; { Deny access to other Processes }π shDenyN = $40; { Deny none - full access to other Processes }π shAccessR = $0; { open for Read access }π shAccessW = $1; { open for Write Access }π shAccessRW = $2; { open for both read and write }π shPrivate = $80; { private mode - don't know what this is... }ππimplementation { the private part }ππfunction shShareInstalled; assembler;π{π Returns TRUE if Share is installed on the local machine!π}πasmπ mov ax,$1000 { check if SHARE is installed }π int $2f { call multiplex interrupt }πend; { shShareInstalled }ππfunction LockByte; assembler;π{π Locks a region of bytes in the specified file.π}πasmπ mov ax, $5c00π les bx, thefileπ mov bx, es:[bx].FileRec.Handleπ les dx, FirstByteπ mov cx, esπ les di, NoBytesπ mov si, esπ int $21π jc @1π xor al, alπ@1:πend;ππfunction Lock; assembler;π{π Lock records.π}πasmπ les bx, thefileπ mov cx, es:[bx].FileRec.RecSizeπ mov ax, FirstRecπ mul cxπ push axπ push dxπ mov ax, NoRecsπ mul cxπ mov si, dxπ mov di, axπ pop cxπ pop dxπ mov ax, $5c00π mov bx, es:[bx].FileRec.Handleπ int $21π jc @1π xor al, alπ@1:πend;ππfunction UnLockByte; assembler;πasmπ mov ax, $5c01π les bx, thefileπ mov bx, es:[bx].FileRec.Handleπ les dx, FirstByteπ mov cx, esπ les di, NoBytesπ mov si, esπ int $21π jc @1π xor al, alπ@1:πend;ππfunction UnLock; assembler;πasmπ les bx, thefileπ mov cx, es:[bx].FileRec.RecSizeπ mov ax, FirstRecπ mul cxπ push axπ push dxπ mov ax, NoRecsπ mul cxπ mov si, dxπ mov di, axπ pop cxπ pop dxπ mov ax, $5c01π mov bx, es:[bx].FileRec.Handleπ int $21π jc @1π xor al, alπ@1:πend;ππend.πππThey're used this way:πLock(MyFile, FirstByteToLock, NoBytesToLock);πLockByte(MyFile, FirstRecToLock, NoRecsToLock);ππSince you're working with records, you probably want to use Lock.πWhen you want to update a record, this might be the code:ππLock(MyFile, Rec, 1);πWrite(MyFile, MyRec);πUnLock(MyFile, Rec, 1);ππYou will of course have to make code to check if the lock failedπ(any result but 0), you can't write to the record. Always unlockπthe record as soon you're done!ππThe last ones are UnLock and UnLockByte. They're used the sameπway as Lock and LockByte.ππAnd a last note! You can't open a file in a mode that conflictsπwith the access other processes have to a file.ππEg.ππif you first open a file with mode shDenyN+shAccessRW, and thenπtry to open the file again (without closing the first one) withπthe mode shDenyRW+shAccessRW, the reset will fail.ππI'll see if I can make a short program to illustrate how thisπworks...ππHope this helps a litte,ππ... Helgeπ 32 11-21-9309:44ALL HELGE OLAV HELGESEN National Language SupportSWAG9311 129 ┤φ π{π Borland Pascal 7.0 National Language Support, with support for protectedπ mode. Written in october 1993 by Helge Olav Helgesenππ The purpose of this unit is to give you the ability to write country-π dependant programs. I won't explain much how it works; since you have theπ source, feel free to explore/change the source.ππ To do so I have a written a colletion of procedures, which are describedπ here:ππ procedure CreateTable(cc: Word);π This one creates a new table with the specified country-code. if youπ specify a value of 0, the default country will be loaded. You shouldπ check for errors thru GetError and PeekError.π procedure DumpTable (const name: string);π This one was written for debugging only, and shoudn't be used. It savesπ the current translation table to the specific fileπ procedure Upper(var s: OpenString);π procedure Lower(var s: OpenString);π These two translates a string into upper or lower case only.π function GetError: word;π function PeekError: word;π These two can be used to get (and clear) the result from lastπ CreateTable. GetError clears ErrorCode afterwards, while PeekErrorπ doesn't.π function Convert2Time(const dt: DateTime): string8;π This one will create a formatted string containing the time specifiedπ in DateTime.Hour, DateTime.Min and DateTime.Sec. The string is formattedπ according to the loaded country.π function Convert2Date(const dt: DateTime): string8;π This one does the same as the one above, except that a date is returnedπ instead.π function ConvertR2Currency(no: real): string;π This one will turn a real value into a formatted string, with the county'sπ currency symbol placed right.π The line 'WriteLn(ConvertR2Currency(1234.123));' will resultπ In USA: $1,234.12π In Norway: Kr 1.234,12π function UpChar(Ch: Char): Char;π function LoChar(Ch: Char): Char;π These two are written with inline statements, and will thus place theπ expanded code into your program's code segment. Since they becameπ fairly large, you shoudn't use them too much.π procedure DumpAllCountries;π This one is only compiled in real mode, and is only intended to use withπ debugging. It writes all countries that is available to the screen.π var Table: TTranslationTable;π This is *the* 256 byte translation table, which contains the mapping toπ upper and lower chars.π var ErrorCode: word;π Result from last CreateTable. This is the Dos error code, as describedπ in 'Run-time error messages'.π var CurrTable: word;π If last CreateTable successed, this contains the country that is loaded.π var UnitOK: boolean;π Is TRUE ifπ 1) Dos 3+ is loadedπ 2) Could allocate real-mode memory (DPMI only)π var CountryInfo: PCountryInfo;π This is a pointer to the current countrys info table. This pointer shouldπ never derefenced unless UnitOK is true. It contains only valid data ifπ (CurrTable>0) and UnitOK!ππ I haven't done much to optimize the code. So even small changes mayπ increase the speed. If you have any comments, suggestion etc. feel freeπ to leave me a note.ππ You can reach me thru the following nets:π ILink - thru Qmail, Programming, ASM and Pascalπ PolarNet - thru Pascal and Postπ Rime - thru Common, Pascal and ASM. I'm located at site MIDNIGHTπ ScanNet - virtually any conferenceπ SourceNet - thru the Pascal conferenceπ WEB - thru the Pascal conferenceππ You may also reach me at the following bulletin boards:π Group One BBS - +1 312 752-1258π Midnight Sun BBS - +47 755 84 545π Programmer's BBS - +47 22 71 41 07ππ In all cases, my name is HELGE HELGESEN. My mail address is:π Helge Olav Helgesenπ Box 726π 8001 BODOEπ Norwayππ Tlf. +47 755 23 694π}π{$S-,B- Do not change these! A change will cause faults! }π{$G+,D+,R-,Q-,L+,O+}π{$IFDEF Windows}Sorry, Windows is not supported...{$ENDIF}ππunit NLS;ππinterfaceππuses {$IFDEF DPMI}WinAPI,{$ENDIF}Dos;ππtypeπ TTranslationTable = array[0..1, 0..127] of char;π AChar = record { ASCIIZ char from Country Info }π Letter: char;π Dummy: byte;π end; { AChar }π PCountryInfo = ^TCountryInfo;π TCountryInfo = recordπ DTFormat: word; { Date/Time format }π CurrSym: array[0..4] of char; { currency symbol }π ThouSep, { thousand separator }π DeciSep, { decimal separator }π DateSep, { date separator }π TimeSep: AChar; { time separator }π CurrFmt: byte; { currency format }π Digits: byte; { digits after decimal }π TimeFmt: boolean; { FALSE=12h else 24h }π CaseMap: pointer; { real mode case map }π DataSep: AChar; { data list separator }π RFU: array[0..9] of byte; { not used }π end; { TCountryInfo }π String8 = string[12];ππvarπ Table: TTranslationTable; { the translation table }π ErrorCode: word; { error code from last create table }π CurrTable: word; { current country loaded, or 0 if none }π UnitOK: boolean; { true if extentions are allowed }π CountryInfo: PCountryInfo; { NB! Protected Mode selector under DPMI! }ππprocedure CreateTable(cp: word);π { -creates new table }πprocedure DumpTable (const name: string);π { -saves table to disk, mainly written for debugging purposes }πprocedure Upper (var s: OpenString);π { -translate string to upper case (A NAME) }πprocedure Lower (var s: OpenString);π { -translate string to lower case (a name) }πfunction GetError: word;π { -get and clear error }πfunction PeekError: word;π { -get error }πfunction Convert2Time(const dt: DateTime): string8;π { -converts time part of DateTime rec info country dep. string }πfunction Convert2Date(const dt: DateTime): string8;π { -converts date part into XX:YY:ZZ country dep. }πfunction ConvertR2Currency(no: real): string;π { -converts real value to currency }πfunction UpChar(Ch: Char): Char;π { -converts char to upper case }πinline($58/ { pop ax }π $88/$c4/ { mov ah, al }π $a8/$80/ { test al, 80h }π $74/$10/ { je @1 }π $8b/$d8/ { mov bx, ax }π $32/$ff/ { xor bh, bh }π $8a/$a7/ { mov ah, [bx+ }π >Table-$80/ { Table-80h] }π $84/$e4/ { test ah, ah }π $74/$0d/ { le @2 }π $88/$e0/ { mov al, ah }π $eb/$09/ { jmp @2 }π{@1:} $f6/$d4/ { not ah }π $f6/$c4/$60/{ test ah, 60h }π $75/$02/ { jne @2 }π $34/$20 { xor al, 20h }π{@2:} );πfunction LoChar(Ch: Char): Char;π { -translates Ch to lower char }πinline($58/ { pop ax }π $a8/$80/ { test al, 80h }π $74/$10/ { le @1 }π $8b/$d8/ { mov bx, ax }π $32/$ff/ { xor bh, bh }π $8a/$a7/ { mov ah, [bx+ }π >Table/ { TABLE] }π $0a/$e4/ { or ah, ah }π $74/$0c/ { je @2 }π $88/$e0/ { mov al, ah }π $eb/$08/ { jmp @2 }π{@1:} $88/$c4/ { mov ah, al }π $a8/$c0/ { test al, 0c0h }π $74/$08/ { je @2 }π $34/$20 { xor al, 20h }π{@2:} );ππ{$IFDEF MSDOS}πprocedure DumpAllCountries;π { -dumps all country codes supported. For debugging. Works only in real mode }π{$ENDIF}ππimplementationππ{$IFDEF DPMI}πtypeπ TBit32 = recordπ Low, High: word;π end; { Bit32 }π TCallRealMode = record { DPMI structure used to call real mode procs }π EDI, ESI, EBP, RFU1, EBX,π EDX, ECX, EAX: TBit32;π Flags, rES, rDS, rFS,π rGS, rIP, rCS, rSP,π rSS: word;π end; { TCallRealMode }ππvarπ ciSelector: TBit32; { selector and segment to CountryInfo }π MyExitProc: pointer; { DPMI exit proc to deallocate Dos memory }π{$ENDIF}ππtypeπ string2 = string[2];π Pstring = ^String;ππfunction Convert2Digit(no: word): string2;πvarπ s: string8;πbeginπ Str(no:2, s);π if s[0]>#2 then delete(s, 1, byte(s[0])-2);π if s[1]=#32 then s[1]:='0';π Convert2Digit:=s;πend; { Convert2Digit }ππ{$IFDEF MSDOS}πprocedure DumpAllCountries;π function TestCountry(no: word): boolean; assembler;π var dummy: TCountryInfo;π asmπ push dsπ mov ax, ssπ mov ds, axπ lea dx, dummyπ mov ax, $38ffπ mov bx, noπ or bh, bhπ je @1π mov al, blπ@1: int $21π pop dsπ jc @xπ xor ax, axπ@x:π end; { DumpAllcountries.TestCountry }πvarπ x: word;πbeginπ for x:=0 to 900 do if not TestCountry(x) then write(x:10);πend; { DumpAllCountries }π{$ENDIF}ππfunction Convert2Time;πconstπ AM: string2 = 'AM';π PM: string2 = 'PM';π function To12(no: word): word;π beginπ if no>12 then To12:=no-12 else To12:=no;π end; { Convert2Time.To12 }π function AmPm(no: word): Pstring;π beginπ if no>12 then AmPm:=@PM else AmPm:=@AM;π end; { Convert2Time.AmPm }πvarπ Delemiter: char;πbegin { Convert2Time }π if UnitOK and (ErrorCode=0) thenπ Delemiter:=CountryInfo^.TimeSep.Letterπ elseπ Delemiter:=':';π if UnitOK and (CurrTable>0) and CountryInfo^.TimeFmt thenπ Convert2Time:=Convert2Digit(dt.Hour)+Delemiter+ { time }π Convert2Digit(dt.Min)+Delemiter+ { min }π Convert2Digit(dt.Sec)π elseπ Convert2Time:=Convert2Digit(To12(dt.Hour))+Delemiter+ { time }π Convert2Digit(dt.Min)+Delemiter+ { min }π Convert2Digit(dt.Sec)+#32+AMPM(dt.Hour)^{ sec }πend; { Convert2Time }ππfunction Convert2Date;πvarπ Dele: char;πbeginπ if UnitOK and (CurrTable>0) thenπ Dele:=CountryInfo^.DateSep.Letterπ elseπ Dele:='/';π if UnitOK and (CurrTable>0) and (CountryInfo^.DTFormat>0) thenπ case CountryInfo^.DTFormat ofπ 1: Convert2Date:=Convert2Digit(dt.Day)+Dele+ { date }π Convert2Digit(dt.Month)+Dele+ { month }π Convert2Digit(dt.Year); { year }π 2: Convert2Date:=Convert2Digit(dt.Year)+Dele+ { year }π Convert2Digit(dt.Month)+Dele+ { month }π Convert2Digit(dt.Day);π end { case }π else { if }π Convert2Date:= Convert2Digit(dt.Month)+Dele+ { month }π Convert2Digit(dt.Day)+Dele+ { day }π Convert2Digit(dt.Year); { year }πend; { Convert2Time }ππfunction ConvertR2Currency;π function GetCurrency: string8;π varπ s: string8;π beginπ s:=CountryInfo^.CurrSym;π while s[byte(s[0])]=#0 do dec(s[0]);π GetCurrency:=s;π end; { ConvertR2Currency.GetCurrency }π function FormatString(s: string): string;π varπ Comma, Digits: byte;π c: integer;π Dele: char;π beginπ Dele:=CountryInfo^.ThouSep.Letter; { get thousand delemiter }π Digits:=Pos('.', s); { digits before delemither }π Comma:=Digits; { save comma position }π if Digits=0 then Digits:=Length(s)+1; { start rightmost if no comma }π c:=Digits-3; { init counter }π while c>2 doπ beginπ Insert(Dele, s, c); { insert thousand delemither }π Dec(c, 3); { adjust pointer }π if Comma>0 then Inc(Comma); { increase comma position(if any) }π end; { while }π if Comma>0 then { adjust comma, if any }π s[Comma]:=CountryInfo^.DeciSep.Letter;π FormatString:=s;π end; { ConvertR2Currency.FormatString }π function PlaceCurrency(s: string): string;π varπ x: byte;π beginπ x:=Pos(CountryInfo^.DeciSep.Letter, s);π Delete(s, x, 1);π Insert(GetCurrency, s, x);π PlaceCurrency:=s;π end; { ConvertR2Currency.PlaceCurrency }πvarπ s: string[20];πbegin { ConvertR2Currency }π if UnitOK and (CurrTable>0) thenπ beginπ Str(no:20:CountryInfo^.Digits, s);π while s[1]=#32 do delete(s, 1, 1);π s:=FormatString(s);π endπ elseπ beginπ Str(no:20:2, s);π while s[1]=#32 do delete(s, 1, 1);π end; { if/else }π if UnitOK and (CurrTable>0) thenπ case CountryInfo^.CurrFmt ofπ 0: s:=GetCurrency+s;π 1: s:=s+GetCurrency;π 2: s:=GetCurrency+#32+s;π 3: s:=s+#32+GetCurrency;π 4: s:=PlaceCurrency(s);π end; { case }π ConvertR2Currency:=s;πend; { ConvertR2Currency }ππprocedure DumpTable;πvarπ f: file of TTranslationTable;πbeginπ assign(f, name);π rewrite(f);π write(f, Table);π close(f);πend;ππprocedure CreateTable;πvarπ b: byte;π c, d: char;π procedure GetCountryInfo(cp: word);π varπ r: Registers;π beginπ r.AX:=$38FF;π if cp>255 then r.BX:=cp else r.AL:=Lo(cp);π r.DS:=Seg(CountryInfo^);π r.DX:=Ofs(CountryInfo^);π MsDos(r);π if r.Flags and 1=1 then ErrorCode:=r.AX;π if ErrorCode=0 then CurrTable:=r.BX else CurrTable:=0;π end; { CreateTable.GetCoutryInfo }π function CallCaseMap(Letter: char): char; assembler;π{$IFNDEF MSDOS}π varπ regs: TCallRealMode;π{$ENDIF}π asmπ mov al, Letterπ {$IFNDEF MSDOS}π mov word ptr regs.EAX, axπ mov regs.rSP, 0π mov regs.rSS, 0π les di, CountryInfoπ mov ax, word ptr es:[di].TCountryInfo.CaseMapπ mov regs.RIP, axπ mov ax, word ptr es:[di].TCountryInfo.CaseMap+2π mov regs.RCS, axπ mov ax, ssπ mov es, axπ lea di, regsπ xor cx, cxπ mov ax, $301π int $31 { execute real mode proc }π mov ax, word ptr regs.EAXπ {$ELSE}π les di, CountryInfoπ call es:[di].TCountryInfo.CaseMapπ {$ENDIF}π end; { CreateTable.CallCaseMap }π procedure MapIn(NewChar, OldChar: char);π beginπ Table[0, byte(OldChar) and $7f]:=NewChar;π Table[1, byte(NewChar) and $7f]:=OldChar;π end; { CreateTable.MapIn }πbegin { CreateTable }π if (ErrorCode>0) or not UnitOK then exit; { leave if any pending error }π FillChar(Table, sizeof(Table), 0);π GetCountryInfo(cp);π if ErrorCode>0 then exit; { leave if any error occured }π for b:=0 to 127 doπ beginπ c:=CallCaseMap(char(b+128));π if c<>char(b+128) then MapIn(c, char(b+128));π end; { for }πend; { CreateTable }ππprocedure UpCase; assembler;π{π This translates the incoming char in AL into upper case if it is definedπ in the translation table.π Please note that if you enable stack checking, this proc won't work...π}πasmπ test al, $80π je @1π xor ah, ahπ mov bx, axπ mov ah, byte[Table+bx-$80]π test ah, ahπ je @xπ mov al, ahπ jmp @xπ@1:π cmp al, 'z'π jg @xπ cmp al, 'a'π jl @xπ xor al, $20π@x:πend; { UpChar }ππprocedure LowChar; assembler;πasmπ test al, $80π je @1π mov bx, axπ xor bh, bhπ mov ah, byte[Table+bx]π or ah, ahπ je @xπ mov al, ahπ jmp @xπ@1:π cmp al, 'Z'π jg @xπ cmp al, 'A'π jl @xπ xor al, $20π@x:πend; { LowChar }ππprocedure Upper; assembler;πasmπ les di, sπ mov cl, es:[di]π xor ch, chπ jcxz @xπ inc diπ@1:π mov al, es:[di]π call UpCaseπ mov es:[di], alπ inc diπ loop @1π@x:πend; { Upper }ππprocedure Lower; assembler;πasmπ les di, sπ mov cl, es:[di]π xor ch, chπ jcxz @xπ inc diπ@1:π mov al, es:[di]π call LowCharπ mov es:[di], alπ inc diπ loop @1π@x:πend; { Lower }ππfunction GetError; assembler;πasmπ mov ax, ErrorCodeπ mov ErrorCode, 0πend; { GetError }ππfunction PeekError; assembler;πasmπ mov ax, ErrorCodeπend; { PeekError }ππ{$IFNDEF MSDOS}πprocedure Leave; far;πbeginπ ExitProc:=MyExitProc; { change to old handler }π GlobalDosFree(ciSelector.High); { release Dos memory }πend; { Leave }ππprocedure InitExitProc;πbeginπ MyExitProc:=ExitProc; { save old handler }π ExitProc:=@Leave; { save my own handler }πend; { InitExitProc }π{$ENDIF}ππbegin { NLS }π UnitOk:=Lo(DosVersion)>=3; { does only work for Dos 3+ }π if UnitOK then { allocate memory }π beginπ {$IFDEF DPMI}π longint(ciSelector):=GlobalDosAlloc(sizeof(TCountryInfo));π if ciSelector.Low=0 then UnitOK:=False; { if not enough Dos memory }π CountryInfo:=Ptr(ciSelector.Low, 0); { make protected mode pointer }π if UnitOK then InitExitProc; { change exit proc }π {$ELSE}π if MaxAvail>sizeof(CountryInfo^) then{ allocate if enough memory }π New(CountryInfo)π elseπ UnitOK:=False; { or disable extentions }π {$ENDIF}π end; { if UnitOK }πend.π 33 11-02-9317:37ALL JON JASIUNAS Share Multi-Tasking SWAG9311 76 ┤φ {πFrom: JON JASIUNASπSubj: Share Multi-taskingπ}ππ{**************************π * SHARE.PAS v1.0 *π * *π * General purpose file *π * sharing routines *π **************************ππ1992-93 HyperDrive SoftwareπReleased into the public domain.}ππ{$S-,R-,D-}π{$IFOPT O+}π {$F+}π{$ENDIF}ππunit Share;ππ{\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}π interfaceπ{/////////////////////////////////////////////////////////////////////////////}ππconstπ MaxLockRetries : Byte = 10;ππ NormalMode = $02; { ---- 0010 }π ReadOnly = $00; { ---- 0000 }π WriteOnly = $01; { ---- 0001 }π ReadWrite = $02; { ---- 0010 }π DenyAll = $10; { 0001 ---- }π DenyWrite = $20; { 0010 ---- }π DenyRead = $30; { 0011 ---- }π DenyNone = $40; { 0100 ---- }π NoInherit = $70; { 1000 ---- }ππtypeπ Taskers = (NoTasker, DesqView, DoubleDOS, Windows, OS2, NetWare);ππvarπ MultiTasking: Boolean;π MultiTasker : Taskers;π VideoSeg : Word;π VideoOfs : Word;ππprocedure SetFileMode(Mode: Word);π {- Set filemode for typed/untyped files }ππprocedure ResetFileMode;π {- Reset filemode to ReadWrite (02h) }ππprocedure LockFile(var F);π {- Lock file F }ππprocedure UnLockFile(var F);π {- Unlock file F }ππprocedure LockBytes(var F; Start, Bytes: LongInt);π {- Lock Bytes bytes of file F, starting with Start }ππprocedure UnLockBytes(var F; Start, Bytes: LongInt);π {- Unlock Bytes bytes of file F, starting with Start }ππprocedure LockRecords(var F; Start, Records: LongInt);π {- Lock Records records of file F, starting with Start }ππprocedure UnLockRecords(var F; Start, Records: LongInt);π {- Unlock Records records of file F, starting with Start }ππfunction TimeOut: Boolean;π {- Check for LockRetry timeout }ππprocedure TimeOutReset;π {- Reset internal LockRetry counter }ππfunction InDos: Boolean;π {- Is DOS busy? }ππprocedure GiveTimeSlice;π {- Give up remaining CPU time slice }ππprocedure BeginCrit;π {- Enter critical region }ππprocedure EndCrit;π {- End critical region }ππ{\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}π implementationπ{/////////////////////////////////////////////////////////////////////////////}ππusesπ Dos;ππvarπ InDosFlag: ^Word;π LockRetry: Byte;ππ{=============================================================================}ππprocedure FLock(Handle: Word; Pos, Len: LongInt);πInline(π $B8/$00/$5C/ { mov AX,$5C00 ;DOS FLOCK, Lock subfunction}π $8B/$5E/$04/ { mov BX,[BP + 04] ;Place file handle in Bx register}π $C4/$56/$06/ { les DX,[BP + 06] ;Load position in ES:DX}π $8C/$C1/ { mov CX,ES ;Move ES pointer to CX register}π $C4/$7E/$08/ { les DI,[BP + 08] ;Load length in ES:DI}π $8C/$C6/ { mov SI,ES ;Move ES pointer to SI register}π $CD/$21); { int $21 ;Call DOS}ππ{-----------------------------------------------------------------------------}ππprocedure FUnlock(Handle: Word; Pos, Len: LongInt);πInline(π $B8/$01/$5C/ { mov AX,$5C01 ;DOS FLOCK, Unlock subfunction}π $8B/$5E/$04/ { mov BX,[BP + 04] ;Place file handle in Bx register}π $C4/$56/$06/ { les DX,[BP + 06] ;Load position in ES:DX}π $8C/$C1/ { mov CX,ES ;Move ES pointer to CX register}π $C4/$7E/$08/ { les DI,[BP + 08] ;Load length in ES:DI}π $8C/$C6/ { mov SI,ES ;Move ES pointer to SI register}π $CD/$21); { int $21 ;Call DOS}ππ{=============================================================================}ππprocedure SetFileMode(Mode: Word);πbeginπ FileMode := Mode;πend; { SetFileMode }ππ{-----------------------------------------------------------------------------}ππprocedure ResetFileMode;πbeginπ FileMode := NormalMode;πend; { ResetFileMode }ππ{-----------------------------------------------------------------------------}ππprocedure LockFile(var F);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, 0, FileSize(File(F)));πend; { LockFile }ππ{-----------------------------------------------------------------------------}ππprocedure UnLockFile(var F);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, 0, FileSize(File(F)));πend; { UnLockFile }ππ{-----------------------------------------------------------------------------}ππprocedure LockBytes(var F; Start, Bytes: LongInt);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, Start, Bytes);πend; { LockBytes }ππ{-----------------------------------------------------------------------------}ππprocedure UnLockBytes(var F; Start, Bytes: LongInt);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, Start, Bytes);πend; { UnLockBytes }ππ{-----------------------------------------------------------------------------}ππprocedure LockRecords(var F; Start, Records: LongInt);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, Start * FileRec(F).RecSize, Records * FileRec(F).Recπend; { LockBytes }ππ{-----------------------------------------------------------------------------}ππprocedure UnLockRecords(var F; Start, Records: LongInt);πbeginπ If not MultiTasking thenπ Exit;ππ While InDos doπ GiveTimeSlice;ππ FLock(FileRec(F).Handle, Start * FileRec(F).RecSize, Records * FileRec(F).Recπend; { UnLockBytes }ππ{-----------------------------------------------------------------------------}ππfunction TimeOut: Boolean;πbeginπ GiveTimeSlice;π TimeOut := True;ππ If MultiTasking and (LockRetry < MaxLockRetries) thenπ beginπ TimeOut := False;π Inc(LockRetry);π end; { If }πend; { TimeOut }ππ{-----------------------------------------------------------------------------}ππprocedure TimeOutReset;πbeginπ LockRetry := 0;πend; { TimeOutReset }ππ{-----------------------------------------------------------------------------}ππfunction InDos: Boolean;πbegin { InDos }π InDos := InDosFlag^ > 0;πend; { InDos }ππ{-----------------------------------------------------------------------------}ππprocedure GiveTimeSlice; ASSEMBLER;πasm { GiveTimeSlice }π cmp MultiTasker, DesqViewπ je @DVwaitπ cmp MultiTasker, DoubleDOSπ je @DoubleDOSwaitπ cmp MultiTasker, Windowsπ je @WinOS2waitπ cmp MultiTasker, OS2π je @WinOS2waitπ cmp MultiTasker, NetWareπ je @Netwarewaitππ@Doswait:π int $28π jmp @WaitDoneππ@DVwait:π mov AX,$1000π int $15π jmp @WaitDoneππ@DoubleDOSwait:π mov AX,$EE01π int $21π jmp @WaitDoneππ@WinOS2wait:π mov AX,$1680π int $2Fπ jmp @WaitDoneππ@Netwarewait:π mov BX,$000Aπ int $7Aπ jmp @WaitDoneππ@WaitDone:πend; { TimeSlice }ππ{----------------------------------------------------------------------------}ππprocedure BeginCrit; ASSEMBLER;πasm { BeginCrit }π cmp MultiTasker, DesqViewπ je @DVCritπ cmp MultiTasker, DoubleDOSπ je @DoubleDOSCritπ cmp MultiTasker, Windowsπ je @WinCritπ jmp @EndCritππ@DVCrit:π mov AX,$101Bπ int $15π jmp @EndCritππ@DoubleDOSCrit:π mov AX,$EA00π int $21π jmp @EndCritππ@WinCrit:π mov AX,$1681π int $2Fπ jmp @EndCritππ@EndCrit:πend; { BeginCrit }ππ{----------------------------------------------------------------------------}ππprocedure EndCrit; ASSEMBLER;πasm { EndCrit }π cmp MultiTasker, DesqViewπ je @DVCritπ cmp MultiTasker, DoubleDOSπ je @DoubleDOSCritπ cmp MultiTasker, Windowsπ je @WinCritπ jmp @EndCritππ@DVCrit:π mov AX,$101Cπ int $15π jmp @EndCritππ@DoubleDOSCrit:π mov AX,$EB00π int $21π jmp @EndCritππ@WinCrit:π mov AX,$1682π int $2Fπ jmp @EndCritππ@EndCrit:πend; { EndCrit }ππ{============================================================================}ππbegin { Share }π {- Init }π LockRetry:= 0;ππ asmπ @CheckDV:π mov AX, $2B01π mov CX, $4445π mov DX, $5351π int $21π cmp AL, $FFπ je @CheckDoubleDOSπ mov MultiTasker, DesqViewπ jmp @CheckDoneππ @CheckDoubleDOS:π mov AX, $E400π int $21π cmp AL, $00π je @CheckWindowsπ mov MultiTasker, DoubleDOSπ jmp @CheckDoneππ @CheckWindows:π mov AX, $1600π int $2Fπ cmp AL, $00π je @CheckOS2π cmp AL, $80π je @CheckOS2π mov MultiTasker, Windowsπ jmp @CheckDoneππ @CheckOS2:π mov AX, $3001π int $21π cmp AL, $0Aπ je @InOS2π cmp AL, $14π jne @CheckNetwareπ @InOS2:π mov MultiTasker, OS2π jmp @CheckDoneππ @CheckNetware:π mov AX,$7A00π int $2Fπ cmp AL,$FFπ jne @NoTaskerπ mov MultiTasker, NetWareπ jmp @CheckDoneππ @NoTasker:π mov MultiTasker, NoTaskerππ @CheckDone:π {-Set MultiTasking }π cmp MultiTasker, NoTaskerπ mov VideoSeg, $B800π mov VideoOfs, $0000π je @NoMultiTaskerπ mov MultiTasking, $01π {-Get video address }π mov AH, $FEπ les DI, [$B8000000]π int $10π mov VideoSeg, ESπ mov VideoOfs, DIπ jmp @Doneππ @NoMultiTasker:π mov MultiTasking, $00ππ @Done:π {-Get InDos flag }π mov AH, $34π int $21π mov WORD PTR InDosFlag, BXπ mov WORD PTR InDosFlag + 2, ESπ end; { asm }πend. { Share }π 34 09-26-9309:28ALL MARTIN RICHARDSON Redirect DOS I/O SWAG9311 7 ┤φ {****************************************************************************π * Procedure ..... StandardIOπ * Purpose ....... To allow input/output redirection from the DOS commandπ * line.π * Parameters .... Noneπ * Returns ....... N/Aπ * Notes ......... Normal TP writes do not allow i/o redirection. This is aπ * fix for that.π * Author ........ Martin Richardsonπ * Date .......... May 13, 1992π ****************************************************************************}πPROCEDURE StandardIO;πBEGINπ ASSIGN( Input, '' );π RESET( Input );π ASSIGN( Output, '' );π REWRITE( Output );πEND;π 35 11-26-9317:04ALL MARUIS ELLEN DOS Environment Unit SWAG9311 103 ┤φ {πFrom: MARIUS ELLENπSubj: DOS Environmentπ}ππProgram Environment;π{$M $1000,32776,32776 }π{ 1K stack, 32k+8 bytes heap }π{$T- No @ Typed checking}π{$X+ Extended function syntax}π{$Q- No overflow checking}π{$A+ Word align data}π{$S+ Stack checking}ππusesππ dos,π strings;ππtypeππ PJFTRec = ^TJFTRec;π TJFTRec = recordπ JFTtable : array[1..20] of byte;π end;πππ PMCBrec = ^TMCBrec;π TMCBrec = recordπ Next : char; {4d "M", of 5a "Z"}π PSPOwner : word;π Length : word;π Filler : array[0..10] of byte;π end;πππ PPSPrec = ^TPSPrec;π TPSPrec = record {ofs, length }π INT20 :word; {00h 2 BYTEs INT 20 instruction for CP/M CALL 0π program termination the CDh 20hπ here is often used as a signatureπ for a valid PSP }π FreeSeg :word; {02h WORD segment of first byte beyondπ memory allocated to program}π UnUsed04:byte; {04h BYTE unused filler }π CMPCall :byte; {05h BYTE CP/M CALL 5 service requestπ (FAR JMP to 000C0h) BUG: (DOS 2+)π PSPs created by INT 21/AH=4Bhπ point at 000BEh}π CPMSize :word; {06h WORD CP/M compatibility--size ofπ first segment for .COM files}π CPMrem :word; {08h 2 BYTEs remainder of FAR JMP at 05h}π INT22 :pointer; {0Ah DWORD stored INT 22 termination address}π INT23 :pointer; {0Eh DWORD stored INT 23 control-Break addr.}π INT24 :pointer; {12h DWORD DOS 1.1+ stored INT 24 address}π ParPSP :word; {16h WORD segment of parent PSP}π JFT :TJFTRec; {18h 20 BYTEs DOS 2+ Job File Table, one byteπ per file handle, FFh = closed}π SEGEnv :word; {2Ch WORD DOS 2+ segment of environmentπ for process}π SSSP :pointer; {2Eh DWORD DOS 2+ process's SS:SP on entryπ to last INT 21 call}π JFTCount:word; {32h WORD DOS 3+ number of entries in JFTπ (default is 20)}π JFTPtr :pointer; {34h DWORD DOS 3+ pointer to JFTπ (default PSP:0018h)}π PrevPSP :pointer; {38h DWORD DOS 3+ pointer to previous PSPπ (default FFFFFFFFh in 3.x)π used by SHARE in DOS 3.3}π UnUsed3c:byte; {3Ch BYTE apparently unused by DOSπ versions <= 6.00}π UnUsed3d:byte; {3Dh BYTE apparently used by some versionsπ of APPEND}π NovFlag :byte; {3Eh BYTE (Novell NetWare) flag: next byteπ initialized if CEh}π NovTask :byte; {3Fh BYTE (Novell Netware) Novell taskπ number if previous byte is CEh}π DosVers :word; {40h 2 BYTEs DOS 5+ version to return onπ INT 21/AH=30h}π NextPSP :word; {42h WORD (MSWin3) selector of next PSPπ (PDB) in linked list. Windowsπ keeps a linked list of Windowsπ programs only}π UnUsed44:pointer; {44h 4 BYTEs unused by DOS versions <= 6.00}π WinFlag :byte; {48h BYTE (MSWindows3) bit 0 set if non-π Windows application (WINOLDAP)}π UnUsed49:string[6]; {49h 7 BYTEs unused by DOS versions <= 6.00}π RETF21 :string[2]; {50h 3 BYTEs DOS 2+ service request (INTπ 21/RETF instructions)}π UnUsed53:word; {53h 2 BYTEs unused in DOS versions <= 6.00}π UnUsed55:string[6]; {55h 7 BYTEs unused in DOS versions <= 6.00;π can be used to make first FCBπ into an extended FCB }π FCB1 :string[15]; {5Ch 16 BYTEs first default FCB, filled inπ from first commandline argumentπ overwrites second FCB if opened}π FCB2 :string[15]; {6Ch 16 BYTEs second default FCB, filled inπ from second commandlineπ argument, overwrites beginningπ of commandline if opened}π UnUsed7c:pointer; {7Ch 4 BYTEs unused}π DTAArea :string[127];{80h 128 BYTEs commandline / default DTAπ command tail is BYTE for lengthπ of tail, N BYTEs for the tail,π followed by a BYTE containingπ 0Dh}π end;πππ PMCBPSPrec = ^TMCBPSPrec;π TMCBPSPrec = recordπ MCB :TMCBRec;π PSP :TPSPRec;π end;ππvarππ MainEnvSeg:word;π MainEnvSize:word;πππ{$ifndef TryAssembler}π {Find DOS master environment, command/4dos etc...}π procedure GetMainEnvironment(var envseg,envsize:word);π var R:PMCBPSPrec;π Rrec:array[0..1] of word absolute R;π beginπ asmπ mov ah,52h {Get First MCB, }π int $21 {DOS Memory Control Block (MCB)}π mov ax,es:[bx-2] {Bevind zich 2 terug}π mov R.word[0],0 {Offset is altijd 0}π mov R.word[2],ax {MCB:=first DOS mcb}π end;ππ while true do beginπ if pos(R^.mcb.next,'MZ')=0π then halt(7); {Memory control block destroyed}ππ if R^.mcb.PSPOwner=R^.PSP.ParPSP then begin {found}π EnvSeg :=R^.PSP.SegEnv;π R:=Ptr(EnvSeg-1,0);π EnvSize:=R^.mcb.length shl 4;π if EnvSize>32767π then halt(10); {Environment invalid (usually >32K)}π exit;π end;π if R^.mcb.next='Z'π then halt(9); {Memory block address invalid}π {Er moet een environment zijn!}π R:=ptr((Rrec[1]+(R^.mcb.length)+1),0);π end;π end;πππ{$else}π procedure HaltIndirect(error:word);π beginπ halt(error);π end;πππ {Find DOS master environment, command/4dos etc...}π procedure GetMainEnvironment(var envsegP,envsizeP:word);π assembler;π var mcb:pointer;π asmπ mov ah,52h {Get First MCB, }π int $21 {DOS Memory Control Block (MCB)}π sub bx,2π xor dx,dx {offset altijd 0000}π mov ax,es:[bx]π mov mcb.word[0],dxπ mov mcb.word[2],ax {MCB:=first DOS mcb}ππ @repeat:π les di,mcbπ mov bl,es:[di]π cmp bl,4dHπ je @MCBOkπ cmp bl,5aH {was het de laatste MCB}π jne @MCBError {zo ja dan halt(9)}π @MCBOk:π mov ax,es:[01h] {is segment v/h prg bij deze MCB}π cmp ax,es:[26h] {gelijk aan EnvSegment van het prg}π je @found {zo ja dan is ie gevonden}ππ cmp bl,5ah {is dit de laatste mcb ?}π je @MCBMissing {!?!? MCB main env weg!?!?}π les di,mcb {volgende MCB zit op}π mov ax,es {oude MCB+next}π add ax,es:[3] {+volgende}π inc ax {+1}π mov mcb.word[2],axπ jmp @repeat {herhaal tot gevonden}ππ @MCBError:π mov al,7 {Memory control block destroyed}π db 0a9h {skip next mov al,xx=opcode test ax,w}π @MCBMissing:π mov al,9 {Memory block address invalid}π db 0a9h {kan ook environment not found zijn!}π @SizeErr:π mov al,10 {Environment invalid (usually >32K)}π push axπ call HaltIndirectππ @found:π mov ax,es:[3ch] {Get segment environment}π mov dx,es {save es}π les di,EnvSegP {ptr van VAR parameter}π mov es:[di],ax {Store environment segment}π mov es,dx {rest es}ππ dec ax {MCB van env. is 1 paragraaf terug}π mov es,ax {Get Size van env. uit MCB}π mov ax,es:[3] {deze is in paragrafen}π mov cl,4 {en wordt geconverteerd}π shl ax,cl {naar bytes..}ππ les di,EnvSizeP {ptr van VAR parameter}π mov es:[di],ax {Store environment size}π cmp ax,32768 {size moet <32k}π jae @SizeErr {anders een foutmelding}π end;π{$endif}ππ {Seperate Variable and return parameters}π function StripEnvVariable(Variable:pchar):pchar;π const stop='='#32#0;π beginπ While pos(Variable^,stop)=0 do inc(Variable);π StripEnvVariable:=Variable+1;π Variable^:=#0;π end;πππ {like bp's getenv, this time removing spaces}π function GetMainEnv(variable:string):string;π var MainPtr,Params:pchar;π data:array[0..512] of char;π beginπ MainPtr:=ptr(MainEnvSeg,0);π StrPCopy(@variable,variable);π StrUpper(@variable);π StripEnvVariable(@variable);ππ if variable[0]<>#0 then beginπ while (MainPtr^<>#0) do beginπ StrCopy(Data,MainPtr);π Params:=StripEnvVariable(data);π if StrComp(Data,@Variable)=0 then beginπ GetMainEnv:=StrPas(Params);π exit;π end;π MainPtr:=StrEnd(MainPtr)+1;π end;π end;π GetMainEnv:='';π end;πππ {like bp's EnvCount}π function MainEnvCount:integer;π var MainPtr:pchar;π index:integer;π beginπ index:=0;π MainPtr:=ptr(MainEnvSeg,0);π while (MainPtr^<>#0) do beginπ MainPtr:=StrEnd(MainPtr)+1;π inc(index);π end;π MainEnvCount:=index;π end;πππ {like bp's EnvStr}π function MainEnvStr(index:integer):string;π var MainPtr:pchar;π beginπ MainPtr:=ptr(MainEnvSeg,0);π while (MainPtr^<>#0) do beginπ dec(index);π if index=0 then beginπ MainEnvStr:=StrPas(MainPtr);π exit;π end;π MainPtr:=StrEnd(MainPtr)+1;π end;π MainEnvStr:='';π end;πππ {change environment "variable", returning succes}π function MainEnvChange(variable:string; param:string):boolean;π var data:array[0..512] of char;π Mem,MainPtr,EnvPtr:pchar;π NewSize:word absolute EnvPtr;π EnvPtrLong:^Longint absolute EnvPtr;πππ procedure EnvStrCopy(src:pchar);π beginπ if NewSize+StrLen(src)<=MainEnvSize-4π then beginπ StrCopy(EnvPtr,Src);π EnvPtr:=StrEnd(EnvPtr)+1;π endπ else MainEnvChange:=false;π end;ππ procedure PutVariable;π beginπ if (Variable[0]<>#0) and (param[0]<>#0) then beginπ StrCopy(Data,@variable);π StrCat(Data,'=');π StrCat(Data,@param);π EnvStrCopy(Data);π variable[0]:=#0;π end;π end;ππ beginπ getmem(Mem,MainEnvSize);π MainPtr:=ptr(MainEnvSeg,0);π EnvPtr:=Mem;ππ StrPCopy(@variable,variable);π StrUpper(@variable);π StripEnvVariable(@variable);π StrPCopy(@param,param);π MainEnvChange:=variable[0]<>#0;ππ while MainPtr^<>#0 do beginπ StrCopy(Data,MainPtr);π StripEnvVariable(data);π if StrComp(Data,@Variable)=0π then PutVariableπ else EnvStrCopy(MainPtr);π MainPtr:=StrEnd(MainPtr)+1;π end;ππ if variable[0]<>#0π then PutVariable;ππ EnvPtrLong^:=0; {4 terminating zero's}π {1 byte terminating environment}π {2 word counting trailing strings}π {1 byte terminating the strings}π {. last three disables paramstr(0)}π move(Mem^,Ptr(MainEnvSeg,0)^,NewSize+4);π freeMem(Mem,MainEnvSize);π end;πππvar oldprmp:string;πbeginπ GetMainEnvironment(MainEnvSeg,MainEnvSize);π memw[prefixseg:$2c]:=MainEnvSeg;ππ oldprmp:=GetMainEnv('fprompt');π MainEnvChange('prompt','Please type EXIT!'#13#10+'$p$g');ππ swapvectors;π exec(GetMainEnv('comspec'),'');π swapvectors;ππ MainEnvChange('prompt',oldprmp);πend.π 36 09-26-9310:18ALL MIKE DICKSON Is there 4DOS installed SWAG9311 5 ┤φ (*πFrom: MIKE DICKSONπSubj: IS There 4DOSπ*)ππ FUNCTION Running4DOS : Boolean;π VAR Regs : Registers;π beginπ With Regs doπ beginπ ax := $D44D;π bx := $00;π end;π Intr ($2F, Regs);π if Regs.ax = $44DD then Running4DOS := TRUEπ else Running4DOS := FALSEπ end;ππ 37 11-21-9309:28ALL RANDALL WOODMAN Get CMOS Values SWAG9311 72 ┤φ {πFrom: RANDALL WOODMANπSubj: CMOS Infoππ Does anyone know how to get the hard drive type(s) from CMOS ?π}ππUSES DOS,CRT;ππTYPEπ String80 = STRING [80]; { some general purpose string types }π String40 = STRING [40];π String30 = STRING [30];π String20 = STRING [20];π String12 = STRING [12];π String10 = STRING [10];π String5 = STRING [5];ππ CMOSRec = RECORDπ Found : BOOLEAN; { was a CMOS found to exist }π CmosDate : String30; { the date found in CMOS }π CmosTime : String30; { the time found in CMOS }π VideoType : String10; { Type of video found in CMOS }π Coproc : BOOLEAN; { does CMOS report a math coprocessor }π FloppyA : String12; { type of floppy drive for A }π FloppyB : String12; { Type of floppy drive for B }π Hard0 : BYTE; { Type of hard drive for drive 0 }π Hard1 : BYTE; { Type of hard drive for Drive 1 }π ConvenRam : WORD; { amount of conventional ram indicated }π ExtendRam : WORD; { amount of extended Ram indicated }π checkSum : BOOLEAN; { Did checksum pass }π END; { CMOS Rec }ππCONSTπ { values of constants for CMOS }π DayName : ARRAY [0..7] OF STRING [9] = ('Sunday', 'Monday', 'Tuesday',π 'Wednesday', 'Thursday', 'Friday',π 'Saturday', 'Sunday');π MonthName : ARRAY [0..12] OF STRING [9] = ('???', 'January', 'February', 'March',π 'April', 'May', 'June', 'July',π 'August', 'September', 'October',π 'November', 'December');π ScreenName : ARRAY [0..3] OF STRING [10] = ('EGA/VGA', 'CGA 40col',π 'CGA 80col', 'Monochrome');π FloppyName : ARRAY [0..5] OF STRING [11] = ('none', '5.25" 360K',π '5.25" 1.2M', '3.5" 720K',π '3.5" 1.44M', '3.5" 2.88M');π CMOSport : BYTE = $70; { port to access the CMOS }ππ Country : BYTE = 0; { used for country date format }ππ{===========================================================================}πππVARπ Regs : REGISTERS; { General purpose variable to accessπ registers }π CMOS : CMOSRec; { variable to hold CMOS data }ππFUNCTION nocarry : BOOLEAN;π{ returns the status of the carry flag }πBEGINπ nocarry := regs.flags AND fcarry = $0000πEND; {nocarry}ππ{---------------------------------------------------------------------------}ππFUNCTION ByteToWord (ByteA, ByteB : BYTE) : WORD;πBEGINπ ByteToWord := WORD (ByteB) SHL 8 + ByteAπEND; {cbw}ππ{---------------------------------------------------------------------------}ππFUNCTION BitIsSet (CheckWord : WORD; AndValue : WORD) : BOOLEAN;π{ returns true if the bit(s) indicated in AndValue are set in CheckByte }πBEGINπ BitIsSet := CheckWord AND AndValue = AndValue;πEND;ππ{---------------------------------------------------------------------------}ππFUNCTION ReadCMOS (ADDR : BYTE) : BYTE;π{ read a value from the CMOS }πBEGINπ IF CMOSport = $70 THENπ BEGINπ INLINE ($FA);π Port [CMOSport] := ADDR;π readCMOS := Port [CMOSport + 1];π INLINE ($FB)π ENDπEND; {readCMOS}ππ{---------------------------------------------------------------------------}ππFUNCTION addzero (b : BYTE) : string5;πVARπ c2 : STRING [2];πBEGINπ STR (b : 0, c2);π IF b < 10 THENπ c2 := '0' + c2;π addzero := c2πEND; {addzero}ππ{---------------------------------------------------------------------------}ππFUNCTION ChangeBCD (b : BYTE) : BYTE;π{ change a BCD into a byte structure }πBEGINπ ChangeBCD := (b AND $0F) + ( (b SHR 4) * 10)πEND; {ChangeBCD}ππ{---------------------------------------------------------------------------}ππFUNCTION Long2Str (Long : LONGINT) : STRING;πVAR Stg : STRING;πBEGINπ STR (Long, Stg);π Long2Str := Stg;πEND;ππFUNCTION HexL (argument : LONGINT) : STRING; Assembler;π asmπ cldπ les di, @resultπ mov al, 8 { store string length }π stosbπ mov cl, 4 { shift count }ππ mov dx, WORD PTR Argument + 2 { hi word }π call @1 { convert dh to ascii }π mov dh, dl { lo byte of hi word }π call @1 { convert dh to ascii }π mov dx, WORD PTR Argument { lo word }π call @1 { convert dh to ascii }π mov dh, dl { lo byte of lo word }π call @1 { convert dh to ascii }π jmp @2ππ @1 :π mov al, dh { 1 byte }π AND al, 0fh { low nybble }π add al, 90hπ daaπ adc al, 40hπ daaπ mov ah, al { store }π mov al, dh { 1 byte }π SHR al, cl { get high nybble }π add al, 90hπ daaπ adc al, 40hπ daaπ stosw { move characters to result }π retn { return near }π @2 :π END;ππFUNCTION GetCMOSDate : String30;π{ gets the date found in the CMOS and returns it in string format }πVARπ Date,π Century,π Year,π Month : BYTE;π WorkStr : String30;πBEGINπ WorkStr := '';π date := ChangeBCD (readCMOS (7) );π century := ChangeBCD (readCMOS ($32) );π year := ChangeBCD (readCMOS (9) );π month := ChangeBCD (readCMOS (8) );π CASE country OFπ 0, 3..255 :π WorkStr := WorkStr + Monthname [month] + ' ' + Long2Str (date) + ', ' + Long2Str (century) + addzero (year);π 1 :π WorkStr := WorkStr + Long2Str (date) + ', ' + Monthname [month] + ' ' + Long2Str (century) + addzero (Year);π 2 :π WorkStr := WorkStr + Long2Str (century) + addzero (Year) + ', ' + Monthname [month] + ' ' + Long2Str (date);π END; {case}π GetCMosDate := workStr;πEND; { GetCMOSDate }ππ{---------------------------------------------------------------------------}ππFUNCTION GetCmosTime : String30;π{ returns the time as found in the CMOS }πVARπ CH : CHAR;π Hour,π Min,π Sec : BYTE;π WorkStr : String30;π IsPM : BOOLEAN;πBEGINπ workStr := '';π hour := ChangeBCD (readCMOS (4) );π min := ChangeBCD (readCMOS (2) );π sec := ChangeBCD (readCMOS (0) );π IsPm := FALSE;π CASE hour OFπ 0 : hour := 12;π 1..11 : hour := hour;π 12 : IsPM := TRUE;π 13..23 : BEGINπ IsPM := TRUE;π hour := hour - 12π END;π END; {case}π WorkStr := WorkStr + AddZero (hour) + ':' + addzero (min) + ':' + addzero (sec);π IF IsPM THENπ workStr := WorkStr + ' PM'π ELSEπ WorkStr := WorkStr + ' AM';π GetCMOSTime := WorkStr;πEND; { GetCmosTime }ππ{---------------------------------------------------------------------------}ππFUNCTION GetCmosCheckSum : BOOLEAN;π{ performs checksum on CMOS and returns true if ok }πVARπ CheckSum1,π CheckSum2 : WORD;π Count : BYTE;πBEGINπ checksum1 := 0;π FOR count := $10 TO $2D DOπ INC (checksum1, readCMOS (count) );π checksum2 := (WORD (256) * readCMOS ($2E) ) + readCMOS ($2F);π IF checksum1 = checksum2 THENπ GetCmosCheckSum := TRUEπ ELSEπ GetCmosCheckSum := FALSE;πEND; { GetCmosCheckSum }ππ{---------------------------------------------------------------------------}ππPROCEDURE GetCMos;π{ gets the cmos record if it exist }πVARπ Floppy : BYTE;πBEGINπ FILLCHAR (CMOS, SIZEOF (CMos), 0);π regs.AH := $C0;π INTR ($15, regs);π IF nocarry OR (Mem [$F000 : $FFFE] <= $FC) THENπ WITH CMOS DOπ BEGINπ Found := TRUE;π CMOSDate := GetCMOSDate;π CMOSTime := GetCmosTime;π VideoType := ScreenName [ (readCMOS ($14) SHR 4) AND 3];π CoProc := BitIsSet (readCMOS ($14), 1);π Floppy := readCMOS ($10);π IF (Floppy SHR 4) < 5 THENπ FloppyA := FloppyName [floppy SHR 4]π ELSEπ FloppyA := 'Unknown ' + HexL (floppy SHR 4);π IF (floppy AND $0F) < 5 THENπ FloppyB := FloppyName [floppy AND $0F]π ELSEπ FloppyB := 'Unknown ' + HexL (floppy AND $0F);ππ Hard0 := readCMOS ($12);π Hard0 := Hard0 SHR 4;π Hard1 := ReadCmos ($12);π Hard1 := Hard1 AND $0F;π IF Hard0 = $F THENπ Hard0 := readCMOS ($19)π ELSE Hard0 := $FF; { error }π IF Hard1 = $F THENπ Hard1 := readCMOS ($1A)π ELSE Hard1 := $FF;π ConvenRam := WORD (256) * readCMOS ($16) + readCMOS ($15); { value in K }π ExtendRam := WORD (256) * readCMOS ($18) + readCMOS ($17); { value in K }π CheckSum := GetCmosCheckSum;π ENDπ ELSEπ CMOS.Found := FALSE;πEND;ππBEGINπClrScr;πGetCMos;πWith CMOS DOπ BEGINπ WriteLn('Date : ',CMosDate);π WriteLn('Time : ',CMosTime);π WriteLn('Video : ',VideoType);π WriteLn('Math : ',CoProc);π WriteLn('FloppyA : ',FloppyA);π WriteLn('FloppyB : ',FloppyB);π WriteLn('Hard #1 : ',Hard0);π WriteLn('Hard #2 : ',Hard1);π WriteLn('Base Ram : ',ConvenRam,'K');π WriteLn('Ext Ram : ',ExtendRam,'K');π ReadKey;π END;πEND. 38 11-02-9316:48ALL RUUD UPHOFF Pascal Environment SWAG9311 25 ┤φ {πFrom: RUUD UPHOFF Refer#: NONEπSubj: TPENV.PAS Conf: (1221) F-PASCALπ---------------------------------------------------------------------------π}ππUNIT SetEnvir;ππINTERFACEπππ USESπ DOS;πππ TYPEπ EnvSize = 0..16383;πππ PROCEDURE SetEnv( EnvVar,Value : STRING);ππ {-----------------------------------------------------------------------π{ This procedure may be used to setup or change environment variablesπ{ in the environment of the resident copy of COMMAND.COM or 4DOS.COMπ{π{ Note that this will be the ACTIVE copy of the command interpreter, NOTπ{ the primary copy!π{π{ This unit is not tested under DR-DOS.π{π{ Any call of SetEnv must be followed by checking ioresult. The procedureπ{ may return error 8 (out of memory) on too less space in te environment.π{-----------------------------------------------------------------------}πππππIMPLEMENTATIONππππ PROCEDURE SetEnv( EnvVar, Value : STRING);ππ VARπ Link,π PrevLink,π EnvirP : word;ππ Size,π Scan,π Where,π Dif : integer;ππ NewVar,π OldVar,π Test : STRING;πππ FUNCTION CheckSpace(Wanted : integer) : boolean;ππ BEGINπ IF wanted+Scan > Size THENπ inoutres:=8;π CheckSpace := inoutres=0π END;πππ BEGINπ IF inoutres >0 THENπ Exit;π FOR Scan := 1 TO Length(EnvVar) DOπ EnvVar[Scan] := UpCase(EnvVar[Scan]);π EnvVar := EnvVar + '=';π NewVar := EnvVar + Value + #0;π link := PrefixSeg;ππ REPEATπ PrevLink := Link;π Link := memw [link : $16]π UNTIL Link = prevlink;ππ EnvirP := memw [Link : $2C];π Size := memw [Envirp-1 : $03] * 16;π Scan := 0;π Where := -1;π WHILE mem[EnvirP : Scan] <>0 DOππ BEGINπ move( mem[EnvirP : scan], Test[1], 255);π Test[0] := #255;π Test[0] := chr(pos(#0,Test));π IF pos(EnvVar, Test) =1 THENππ BEGINπ Where := Scan;π OldVar := Testπ END;ππ Scan := Scan + Length(Test)π END;ππ IF Where = -1 THENππ BEGINπ Where := Scan;π NewVar := NewVar + #0#0#0;π IF NOT CheckSpace( Length(NewVar) ) THENπ Exitπ ENDππ ELSEππ BEGINπ Dif := Length(NewVar) - Length(OldVar);π IF Dif >0 THENππ BEGINπ IF NOT CheckSpace(Dif) THENπ Exit;π move( mem[ EnvirP : Where ],π mem[ EnvirP : Where + Dif ],π Scan-Where+3)π ENDππ ELSE IF Dif <0 THENπ move( mem[ EnvirP : Where - Dif ],π mem[ EnvirP : Where ],π Size-Where+Dif)π END;ππ move( NewVar[1], mem[EnvirP : Where], Length(NewVar) )π END;ππEND.π 39 11-21-9309:30ALL SWAG SUPPORT TEAM FLUSHDOS.PAS SWAG9311 12 ┤φ PROGRAM FlushDem;ππ FUNCTION DosFlush(VAR F) : BOOLEAN; Assembler;π ASMπ MOV AX, 3000h {get DOS version}π INT 21hπ CMP AL, 3 {DOS < 3? old!}π JL @oldπ CMP AH, 1Eh {DOS < 3.3? old!}π LES DI, Fπ MOV BX, ES:[DI] {file handle is first word}π MOV AH, 68h {commit file function}π INT 21hπ JC @BadEndπ JMP @GoodEndππ @old:π LES DI, Fπ MOV BX, ES:[DI] {file handle is first word}π MOV AH, 45h {duplicate handle function}π INT 21hπ JC @BadEndπ @ok:π MOV BX, AX {put duped handle in BX...}π MOV AH, 3Eh {... and close it}π INT 21hπ JC @BadEndπ @GoodEnd:π MOV AX, 0π @BadEnd:π END;ππVARπ T1, T2 : Text;π S : String;π W : Word;πBEGINπ Assign(T1, 'DEMO1.$$$');π Rewrite(T1);π Assign(T2, 'DEMO2.$$$');π Rewrite(T2);π S := 'This is just a sample line of text.';π FOR W := 1 to 100 DOπ BEGINπ WriteLn(T1, W:4, ' ', S);π WriteLn(T2, W:4, ' ', S);π END;π IF DosFlush(T2) THENπ BEGINπ WriteLn('Successfully flushed the second demo ',π 'file. Please reboot your computer.');π ReadLn;π WriteLn('Hey, I said PLEASE reboot. Oh well... ',π ' I will erase the temporary files.');π Close(T1); Erase(T1);π Close(T2); Erase(T2);π ENDπ ELSE WriteLn('DosFlush routine failed.');πEND.
